{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Fadno.Braids.Internal
    (
     -- * Generators
     Gen(..),gPos,gPol
     ,Polarity(..),power,complement
     -- * Representations
     ,Braid(..)
     ,Artin(..),aGens
     ,MultiGen(..),Step(..),mSteps
    ,insertWithS,insertS,lookupS,deleteS,stepGens,stepToGens,gensToStep
    ,DimBraid(..),dim,dBraid,dSteps,dStrands
     -- * Strands, loops, weaves
    ,Weave,ToWeaves(..)
    ,Strand(..),strand,strand',strands,sWeaves,sLast
    ,Loop(..),toLoops,lStrands
     -- * Moves/isotopy
    ,Move(..),inverse,moveH,moveW,Loc(..),lx,ly
    ) where

import Control.Lens hiding (Empty)
import Numeric.Natural
import Control.Arrow
import Data.Semigroup

-- | Braid generator "power", as (i + 1) "over/under" i.
-- O[ver] == power 1 (i + 1 "over" i)
-- U[nder] = power -1 (i + 1 "under" i)
data Polarity = U | O deriving (Polarity -> Polarity -> Bool
(Polarity -> Polarity -> Bool)
-> (Polarity -> Polarity -> Bool) -> Eq Polarity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Polarity -> Polarity -> Bool
== :: Polarity -> Polarity -> Bool
$c/= :: Polarity -> Polarity -> Bool
/= :: Polarity -> Polarity -> Bool
Eq,Int -> Polarity -> ShowS
[Polarity] -> ShowS
Polarity -> String
(Int -> Polarity -> ShowS)
-> (Polarity -> String) -> ([Polarity] -> ShowS) -> Show Polarity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Polarity -> ShowS
showsPrec :: Int -> Polarity -> ShowS
$cshow :: Polarity -> String
show :: Polarity -> String
$cshowList :: [Polarity] -> ShowS
showList :: [Polarity] -> ShowS
Show,Int -> Polarity
Polarity -> Int
Polarity -> [Polarity]
Polarity -> Polarity
Polarity -> Polarity -> [Polarity]
Polarity -> Polarity -> Polarity -> [Polarity]
(Polarity -> Polarity)
-> (Polarity -> Polarity)
-> (Int -> Polarity)
-> (Polarity -> Int)
-> (Polarity -> [Polarity])
-> (Polarity -> Polarity -> [Polarity])
-> (Polarity -> Polarity -> [Polarity])
-> (Polarity -> Polarity -> Polarity -> [Polarity])
-> Enum Polarity
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Polarity -> Polarity
succ :: Polarity -> Polarity
$cpred :: Polarity -> Polarity
pred :: Polarity -> Polarity
$ctoEnum :: Int -> Polarity
toEnum :: Int -> Polarity
$cfromEnum :: Polarity -> Int
fromEnum :: Polarity -> Int
$cenumFrom :: Polarity -> [Polarity]
enumFrom :: Polarity -> [Polarity]
$cenumFromThen :: Polarity -> Polarity -> [Polarity]
enumFromThen :: Polarity -> Polarity -> [Polarity]
$cenumFromTo :: Polarity -> Polarity -> [Polarity]
enumFromTo :: Polarity -> Polarity -> [Polarity]
$cenumFromThenTo :: Polarity -> Polarity -> Polarity -> [Polarity]
enumFromThenTo :: Polarity -> Polarity -> Polarity -> [Polarity]
Enum,Eq Polarity
Eq Polarity =>
(Polarity -> Polarity -> Ordering)
-> (Polarity -> Polarity -> Bool)
-> (Polarity -> Polarity -> Bool)
-> (Polarity -> Polarity -> Bool)
-> (Polarity -> Polarity -> Bool)
-> (Polarity -> Polarity -> Polarity)
-> (Polarity -> Polarity -> Polarity)
-> Ord Polarity
Polarity -> Polarity -> Bool
Polarity -> Polarity -> Ordering
Polarity -> Polarity -> Polarity
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
$ccompare :: Polarity -> Polarity -> Ordering
compare :: Polarity -> Polarity -> Ordering
$c< :: Polarity -> Polarity -> Bool
< :: Polarity -> Polarity -> Bool
$c<= :: Polarity -> Polarity -> Bool
<= :: Polarity -> Polarity -> Bool
$c> :: Polarity -> Polarity -> Bool
> :: Polarity -> Polarity -> Bool
$c>= :: Polarity -> Polarity -> Bool
>= :: Polarity -> Polarity -> Bool
$cmax :: Polarity -> Polarity -> Polarity
max :: Polarity -> Polarity -> Polarity
$cmin :: Polarity -> Polarity -> Polarity
min :: Polarity -> Polarity -> Polarity
Ord)


-- | Polarity to signum or "power" in literature.
power :: Integral a => Polarity -> a
power :: forall a. Integral a => Polarity -> a
power Polarity
O = a
1
power Polarity
U = -a
1

-- | Flip polarity.
complement :: Polarity -> Polarity
complement :: Polarity -> Polarity
complement Polarity
O = Polarity
U
complement Polarity
U = Polarity
O




-- | Braid generator pairing position (absolute or relative)
-- and polarity.
data Gen a = Gen { forall a. Gen a -> a
_gPos :: a, forall a. Gen a -> Polarity
_gPol :: Polarity }
    deriving (Gen a -> Gen a -> Bool
(Gen a -> Gen a -> Bool) -> (Gen a -> Gen a -> Bool) -> Eq (Gen a)
forall a. Eq a => Gen a -> Gen a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Gen a -> Gen a -> Bool
== :: Gen a -> Gen a -> Bool
$c/= :: forall a. Eq a => Gen a -> Gen a -> Bool
/= :: Gen a -> Gen a -> Bool
Eq,(forall a b. (a -> b) -> Gen a -> Gen b)
-> (forall a b. a -> Gen b -> Gen a) -> Functor Gen
forall a b. a -> Gen b -> Gen a
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Gen a -> Gen b
fmap :: forall a b. (a -> b) -> Gen a -> Gen b
$c<$ :: forall a b. a -> Gen b -> Gen a
<$ :: forall a b. a -> Gen b -> Gen a
Functor,Eq (Gen a)
Eq (Gen a) =>
(Gen a -> Gen a -> Ordering)
-> (Gen a -> Gen a -> Bool)
-> (Gen a -> Gen a -> Bool)
-> (Gen a -> Gen a -> Bool)
-> (Gen a -> Gen a -> Bool)
-> (Gen a -> Gen a -> Gen a)
-> (Gen a -> Gen a -> Gen a)
-> Ord (Gen a)
Gen a -> Gen a -> Bool
Gen a -> Gen a -> Ordering
Gen a -> Gen a -> Gen a
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 a. Ord a => Eq (Gen a)
forall a. Ord a => Gen a -> Gen a -> Bool
forall a. Ord a => Gen a -> Gen a -> Ordering
forall a. Ord a => Gen a -> Gen a -> Gen a
$ccompare :: forall a. Ord a => Gen a -> Gen a -> Ordering
compare :: Gen a -> Gen a -> Ordering
$c< :: forall a. Ord a => Gen a -> Gen a -> Bool
< :: Gen a -> Gen a -> Bool
$c<= :: forall a. Ord a => Gen a -> Gen a -> Bool
<= :: Gen a -> Gen a -> Bool
$c> :: forall a. Ord a => Gen a -> Gen a -> Bool
> :: Gen a -> Gen a -> Bool
$c>= :: forall a. Ord a => Gen a -> Gen a -> Bool
>= :: Gen a -> Gen a -> Bool
$cmax :: forall a. Ord a => Gen a -> Gen a -> Gen a
max :: Gen a -> Gen a -> Gen a
$cmin :: forall a. Ord a => Gen a -> Gen a -> Gen a
min :: Gen a -> Gen a -> Gen a
Ord)
instance (Show a) => Show (Gen a) where
    show :: Gen a -> String
show (Gen a
a Polarity
pol) = String
"Gen " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Polarity -> String
forall a. Show a => a -> String
show Polarity
pol
makeLenses ''Gen


-- | Braid as "Artin generators" (one-at-a-time).
newtype Artin a = Artin { forall a. Artin a -> [Gen a]
_aGens :: [Gen a] }
    deriving (Artin a -> Artin a -> Bool
(Artin a -> Artin a -> Bool)
-> (Artin a -> Artin a -> Bool) -> Eq (Artin a)
forall a. Eq a => Artin a -> Artin a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Artin a -> Artin a -> Bool
== :: Artin a -> Artin a -> Bool
$c/= :: forall a. Eq a => Artin a -> Artin a -> Bool
/= :: Artin a -> Artin a -> Bool
Eq,Int -> Artin a -> ShowS
[Artin a] -> ShowS
Artin a -> String
(Int -> Artin a -> ShowS)
-> (Artin a -> String) -> ([Artin a] -> ShowS) -> Show (Artin a)
forall a. Show a => Int -> Artin a -> ShowS
forall a. Show a => [Artin a] -> ShowS
forall a. Show a => Artin a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Artin a -> ShowS
showsPrec :: Int -> Artin a -> ShowS
$cshow :: forall a. Show a => Artin a -> String
show :: Artin a -> String
$cshowList :: forall a. Show a => [Artin a] -> ShowS
showList :: [Artin a] -> ShowS
Show,NonEmpty (Artin a) -> Artin a
Artin a -> Artin a -> Artin a
(Artin a -> Artin a -> Artin a)
-> (NonEmpty (Artin a) -> Artin a)
-> (forall b. Integral b => b -> Artin a -> Artin a)
-> Semigroup (Artin a)
forall b. Integral b => b -> Artin a -> Artin a
forall a. NonEmpty (Artin a) -> Artin a
forall a. Artin a -> Artin a -> Artin a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall a b. Integral b => b -> Artin a -> Artin a
$c<> :: forall a. Artin a -> Artin a -> Artin a
<> :: Artin a -> Artin a -> Artin a
$csconcat :: forall a. NonEmpty (Artin a) -> Artin a
sconcat :: NonEmpty (Artin a) -> Artin a
$cstimes :: forall a b. Integral b => b -> Artin a -> Artin a
stimes :: forall b. Integral b => b -> Artin a -> Artin a
Semigroup,Semigroup (Artin a)
Artin a
Semigroup (Artin a) =>
Artin a
-> (Artin a -> Artin a -> Artin a)
-> ([Artin a] -> Artin a)
-> Monoid (Artin a)
[Artin a] -> Artin a
Artin a -> Artin a -> Artin a
forall a. Semigroup (Artin a)
forall a. Artin a
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall a. [Artin a] -> Artin a
forall a. Artin a -> Artin a -> Artin a
$cmempty :: forall a. Artin a
mempty :: Artin a
$cmappend :: forall a. Artin a -> Artin a -> Artin a
mappend :: Artin a -> Artin a -> Artin a
$cmconcat :: forall a. [Artin a] -> Artin a
mconcat :: [Artin a] -> Artin a
Monoid,(forall a b. (a -> b) -> Artin a -> Artin b)
-> (forall a b. a -> Artin b -> Artin a) -> Functor Artin
forall a b. a -> Artin b -> Artin a
forall a b. (a -> b) -> Artin a -> Artin b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Artin a -> Artin b
fmap :: forall a b. (a -> b) -> Artin a -> Artin b
$c<$ :: forall a b. a -> Artin b -> Artin a
<$ :: forall a b. a -> Artin b -> Artin a
Functor)
instance Foldable Artin where
    foldMap :: forall m a. Monoid m => (a -> m) -> Artin a -> m
foldMap a -> m
f = (a -> m) -> [a] -> m
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f ([a] -> m) -> (Artin a -> [a]) -> Artin a -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Gen a -> a) -> [Gen a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map Gen a -> a
forall a. Gen a -> a
_gPos ([Gen a] -> [a]) -> (Artin a -> [Gen a]) -> Artin a -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Artin a -> [Gen a]
forall a. Artin a -> [Gen a]
_aGens
makeLenses ''Artin

-- | Braid "step" of many-at-a-time generators.
-- Absolute-head-offset-tail structure disallows
-- invalid adjacent generators.
-- Example: 'Step (Gen 1 U) [Gen 0 O]' translates to [s1,s3^-1].
data Step a =
    Empty |
    Step {
      -- | Absolute-indexed "top" generator
      forall a. Step a -> Gen a
_sHead :: Gen a
      -- | (offset + 2)-indexed tail generators.
    , forall a. Step a -> [Gen Natural]
_sOffsets :: [Gen Natural]
    } deriving (Step a -> Step a -> Bool
(Step a -> Step a -> Bool)
-> (Step a -> Step a -> Bool) -> Eq (Step a)
forall a. Eq a => Step a -> Step a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Step a -> Step a -> Bool
== :: Step a -> Step a -> Bool
$c/= :: forall a. Eq a => Step a -> Step a -> Bool
/= :: Step a -> Step a -> Bool
Eq)
makeLenses ''Step
instance Show a => Show (Step a) where
    show :: Step a -> String
show Step a
Empty = String
"Empty"
    show (Step Gen a
h [Gen Natural]
os) = String
"Step (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Gen a -> String
forall a. Show a => a -> String
show Gen a
h String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Gen Natural] -> String
forall a. Show a => a -> String
show [Gen Natural]
os



-- | Insert a gen at absolute index into a 'Step'.
-- Ignores invalid indices, uses function with new, old value
-- for update.
insertWithS :: forall a . Integral a => (Polarity -> Polarity -> Polarity) -> Gen a -> Step a -> Step a
insertWithS :: forall a.
Integral a =>
(Polarity -> Polarity -> Polarity) -> Gen a -> Step a -> Step a
insertWithS Polarity -> Polarity -> Polarity
_ Gen a
g Step a
Empty = Gen a -> [Gen Natural] -> Step a
forall a. Gen a -> [Gen Natural] -> Step a
Step Gen a
g []
insertWithS Polarity -> Polarity -> Polarity
f (Gen a
k Polarity
p) s :: Step a
s@(Step (Gen a
hi Polarity
hp) [Gen Natural]
sgs)
    | a -> Bool
invalid a
hi = Step a
s
    | a
k a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
hi = Gen a -> [Gen Natural] -> Step a
forall a. Gen a -> [Gen Natural] -> Step a
Step (a -> Polarity -> Gen a
forall a. a -> Polarity -> Gen a
Gen a
k Polarity
p) (Natural -> Polarity -> Gen Natural
forall a. a -> Polarity -> Gen a
Gen (a -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> Natural) -> a -> Natural
forall a b. (a -> b) -> a -> b
$ a
hi a -> a -> a
forall a. Num a => a -> a -> a
- a
k a -> a -> a
forall a. Num a => a -> a -> a
- a
2) Polarity
hpGen Natural -> [Gen Natural] -> [Gen Natural]
forall a. a -> [a] -> [a]
:[Gen Natural]
sgs)
    | a
k a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
hi = ASetter (Step a) (Step a) Polarity Polarity
-> Polarity -> Step a -> Step a
forall s t a b. ASetter s t a b -> b -> s -> t
set ((Gen a -> Identity (Gen a)) -> Step a -> Identity (Step a)
forall a a (f :: * -> *).
Applicative f =>
(Gen a -> f (Gen a)) -> Step a -> f (Step a)
sHead((Gen a -> Identity (Gen a)) -> Step a -> Identity (Step a))
-> ((Polarity -> Identity Polarity) -> Gen a -> Identity (Gen a))
-> ASetter (Step a) (Step a) Polarity Polarity
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Polarity -> Identity Polarity) -> Gen a -> Identity (Gen a)
forall a (f :: * -> *).
Functor f =>
(Polarity -> f Polarity) -> Gen a -> f (Gen a)
gPol) (Polarity -> Polarity -> Polarity
f Polarity
p Polarity
hp) Step a
s
    | Bool
otherwise = ASetter (Step a) (Step a) [Gen Natural] [Gen Natural]
-> [Gen Natural] -> Step a -> Step a
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter (Step a) (Step a) [Gen Natural] [Gen Natural]
forall a (f :: * -> *).
Applicative f =>
([Gen Natural] -> f [Gen Natural]) -> Step a -> f (Step a)
sOffsets (a -> [Gen Natural] -> [Gen Natural]
ins a
hi [Gen Natural]
sgs) Step a
s
    where invalid :: a -> Bool
invalid a
i = a
k a -> a -> a
forall a. Num a => a -> a -> a
+ a
1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
i Bool -> Bool -> Bool
|| a
i a -> a -> a
forall a. Num a => a -> a -> a
+ a
1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
k
          ins :: a -> [Gen Natural] -> [Gen Natural]
          ins :: a -> [Gen Natural] -> [Gen Natural]
ins a
i [] = [Natural -> Polarity -> Gen Natural
forall a. a -> Polarity -> Gen a
Gen (a -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> Natural) -> a -> Natural
forall a b. (a -> b) -> a -> b
$ a
k a -> a -> a
forall a. Num a => a -> a -> a
- a
i a -> a -> a
forall a. Num a => a -> a -> a
- a
2) Polarity
p]
          ins a
i gss :: [Gen Natural]
gss@(g :: Gen Natural
g@(Gen Natural
gi Polarity
gp):[Gen Natural]
gs)
              | a -> Bool
invalid a
i' = [Gen Natural]
gss
              | a
k a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
i' = Natural -> Polarity -> Gen Natural
forall a. a -> Polarity -> Gen a
Gen (a -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> Natural) -> a -> Natural
forall a b. (a -> b) -> a -> b
$ a
k a -> a -> a
forall a. Num a => a -> a -> a
- a
i a -> a -> a
forall a. Num a => a -> a -> a
- a
2) Polarity
pGen Natural -> [Gen Natural] -> [Gen Natural]
forall a. a -> [a] -> [a]
:
                         Natural -> Polarity -> Gen Natural
forall a. a -> Polarity -> Gen a
Gen (a -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> Natural) -> a -> Natural
forall a b. (a -> b) -> a -> b
$ a
i' a -> a -> a
forall a. Num a => a -> a -> a
- a
k a -> a -> a
forall a. Num a => a -> a -> a
- a
2) Polarity
gpGen Natural -> [Gen Natural] -> [Gen Natural]
forall a. a -> [a] -> [a]
:[Gen Natural]
gs
              | a
k a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
i' = ASetter (Gen Natural) (Gen Natural) Polarity Polarity
-> Polarity -> Gen Natural -> Gen Natural
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter (Gen Natural) (Gen Natural) Polarity Polarity
forall a (f :: * -> *).
Functor f =>
(Polarity -> f Polarity) -> Gen a -> f (Gen a)
gPol (Polarity -> Polarity -> Polarity
f Polarity
p Polarity
gp) Gen Natural
gGen Natural -> [Gen Natural] -> [Gen Natural]
forall a. a -> [a] -> [a]
:[Gen Natural]
gs
              | Bool
otherwise = Gen Natural
gGen Natural -> [Gen Natural] -> [Gen Natural]
forall a. a -> [a] -> [a]
:a -> [Gen Natural] -> [Gen Natural]
ins a
i' [Gen Natural]
gs
              where i' :: a
i' = a
i a -> a -> a
forall a. Num a => a -> a -> a
+ Natural -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
gi a -> a -> a
forall a. Num a => a -> a -> a
+ a
2

-- | Insert a gen at absolute index into a 'Step'.
-- Ignores invalid indices, overwrites on update.
insertS :: Integral a => Gen a -> Step a -> Step a
insertS :: forall a. Integral a => Gen a -> Step a -> Step a
insertS = (Polarity -> Polarity -> Polarity) -> Gen a -> Step a -> Step a
forall a.
Integral a =>
(Polarity -> Polarity -> Polarity) -> Gen a -> Step a -> Step a
insertWithS Polarity -> Polarity -> Polarity
forall a b. a -> b -> a
const

-- | Lookup by absolute index in a 'Step'.
lookupS :: Integral a => a -> Step a -> Maybe Polarity
lookupS :: forall a. Integral a => a -> Step a -> Maybe Polarity
lookupS a
k = [Gen a] -> Maybe Polarity
lkp ([Gen a] -> Maybe Polarity)
-> (Step a -> [Gen a]) -> Step a -> Maybe Polarity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Step a -> [Gen a]
forall a. Integral a => Step a -> [Gen a]
stepToGens where
    lkp :: [Gen a] -> Maybe Polarity
lkp [] = Maybe Polarity
forall a. Maybe a
Nothing
    lkp (Gen a
a Polarity
p:[Gen a]
gs) | a
k a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
a = Polarity -> Maybe Polarity
forall a. a -> Maybe a
Just Polarity
p
                     | Bool
otherwise = [Gen a] -> Maybe Polarity
lkp [Gen a]
gs

-- | Delete/clear a gen at absolute index.
deleteS :: Integral a => a -> Step a -> Step a
deleteS :: forall a. Integral a => a -> Step a -> Step a
deleteS a
a = [Gen a] -> Step a
forall a. Integral a => [Gen a] -> Step a
gensToStep ([Gen a] -> Step a) -> (Step a -> [Gen a]) -> Step a -> Step a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Gen a] -> [Gen a]
del ([Gen a] -> [Gen a]) -> (Step a -> [Gen a]) -> Step a -> [Gen a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Step a -> [Gen a]
forall a. Integral a => Step a -> [Gen a]
stepToGens where
    del :: [Gen a] -> [Gen a]
del [] = []
    del (g :: Gen a
g@(Gen a
i Polarity
_):[Gen a]
gs) | a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
i = [Gen a]
gs
                         | Bool
otherwise = Gen a
gGen a -> [Gen a] -> [Gen a]
forall a. a -> [a] -> [a]
:[Gen a] -> [Gen a]
del [Gen a]
gs



-- | translate 'Step' to absolute-indexed gens.
stepToGens :: Integral a => Step a -> [Gen a]
stepToGens :: forall a. Integral a => Step a -> [Gen a]
stepToGens Step a
Empty = []
stepToGens (Step Gen a
h [Gen Natural]
gs) = [Gen a] -> [Gen a]
forall a. [a] -> [a]
reverse ([Gen a] -> [Gen a]) -> [Gen a] -> [Gen a]
forall a b. (a -> b) -> a -> b
$ ([Gen a] -> Gen Natural -> [Gen a])
-> [Gen a] -> [Gen Natural] -> [Gen a]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [Gen a] -> Gen Natural -> [Gen a]
forall {a} {a}. (Integral a, Num a) => [Gen a] -> Gen a -> [Gen a]
conv [Gen a
h] [Gen Natural]
gs
    where conv :: [Gen a] -> Gen a -> [Gen a]
conv rs :: [Gen a]
rs@(Gen a
p' Polarity
_:[Gen a]
_) (Gen a
p Polarity
e) = a -> Polarity -> Gen a
forall a. a -> Polarity -> Gen a
Gen (a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
p a -> a -> a
forall a. Num a => a -> a -> a
+ a
p' a -> a -> a
forall a. Num a => a -> a -> a
+ a
2) Polarity
eGen a -> [Gen a] -> [Gen a]
forall a. a -> [a] -> [a]
:[Gen a]
rs
          conv [Gen a]
_ Gen a
_ = String -> [Gen a]
forall a. HasCallStack => String -> a
error String
"c'est impossible"

-- | translate absolute-indexed gens to 'Step'.
-- Drops invalid values.
gensToStep :: (Integral a) => [Gen a] -> Step a
gensToStep :: forall a. Integral a => [Gen a] -> Step a
gensToStep = (Step a -> Gen a -> Step a) -> Step a -> [Gen a] -> Step a
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ((Gen a -> Step a -> Step a) -> Step a -> Gen a -> Step a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Gen a -> Step a -> Step a
forall a. Integral a => Gen a -> Step a -> Step a
insertS) Step a
forall a. Step a
Empty

-- | Iso for valid constructions.
stepGens :: Integral a => Iso' (Step a) [Gen a]
stepGens :: forall a. Integral a => Iso' (Step a) [Gen a]
stepGens = (Step a -> [Gen a])
-> ([Gen a] -> Step a) -> Iso (Step a) (Step a) [Gen a] [Gen a]
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso Step a -> [Gen a]
forall a. Integral a => Step a -> [Gen a]
stepToGens [Gen a] -> Step a
forall a. Integral a => [Gen a] -> Step a
gensToStep


invertS :: Integral a => a -> Step a -> Step a
invertS :: forall a. Integral a => a -> Step a -> Step a
invertS a
maxV = (Step a -> Gen a -> Step a) -> Step a -> [Gen a] -> Step a
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ((Gen a -> Step a -> Step a) -> Step a -> Gen a -> Step a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Gen a -> Step a -> Step a
forall a. Integral a => Gen a -> Step a -> Step a
insertS) Step a
forall a. Step a
Empty ([Gen a] -> Step a) -> (Step a -> [Gen a]) -> Step a -> Step a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Gen a] -> [Gen a]
invGens ([Gen a] -> [Gen a]) -> (Step a -> [Gen a]) -> Step a -> [Gen a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Step a -> [Gen a]
forall a. Integral a => Step a -> [Gen a]
stepToGens
    where invGens :: [Gen a] -> [Gen a]
invGens = ASetter [Gen a] [Gen a] a a -> (a -> a) -> [Gen a] -> [Gen a]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((Gen a -> Identity (Gen a)) -> [Gen a] -> Identity [Gen a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse((Gen a -> Identity (Gen a)) -> [Gen a] -> Identity [Gen a])
-> ((a -> Identity a) -> Gen a -> Identity (Gen a))
-> ASetter [Gen a] [Gen a] a a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(a -> Identity a) -> Gen a -> Identity (Gen a)
forall a a (f :: * -> *).
Functor f =>
(a -> f a) -> Gen a -> f (Gen a)
gPos) (a
maxV a -> a -> a
forall a. Num a => a -> a -> a
-)





type instance Index (Step a) = a
type instance IxValue (Step a) = Polarity
instance Integral a => Ixed (Step a) where
  ix :: Index (Step a) -> Traversal' (Step a) (IxValue (Step a))
ix Index (Step a)
k IxValue (Step a) -> f (IxValue (Step a))
f Step a
m = case a -> Step a -> Maybe Polarity
forall a. Integral a => a -> Step a -> Maybe Polarity
lookupS a
Index (Step a)
k Step a
m of
     Just Polarity
v  -> IxValue (Step a) -> f (IxValue (Step a))
f IxValue (Step a)
Polarity
v f Polarity -> (Polarity -> Step a) -> f (Step a)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Polarity
v' -> Gen a -> Step a -> Step a
forall a. Integral a => Gen a -> Step a -> Step a
insertS (a -> Polarity -> Gen a
forall a. a -> Polarity -> Gen a
Gen a
Index (Step a)
k Polarity
v') Step a
m
     Maybe Polarity
Nothing -> Step a -> f (Step a)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Step a
m
  {-# INLINE ix #-}
instance Integral a => Semigroup (Step a) where
    Step a
a <> :: Step a -> Step a -> Step a
<> Step a
b = (Step a -> Gen a -> Step a) -> Step a -> [Gen a] -> Step a
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Step a -> Gen a -> Step a
forall {a}. Integral a => Step a -> Gen a -> Step a
ins Step a
a (Step a -> [Gen a]
forall a. Integral a => Step a -> [Gen a]
stepToGens Step a
b)
        where ins :: Step a -> Gen a -> Step a
ins Step a
s Gen a
g = (Polarity -> Polarity -> Polarity) -> Gen a -> Step a -> Step a
forall a.
Integral a =>
(Polarity -> Polarity -> Polarity) -> Gen a -> Step a -> Step a
insertWithS ((Polarity -> Polarity -> Polarity)
-> Polarity -> Polarity -> Polarity
forall a b c. (a -> b -> c) -> b -> a -> c
flip Polarity -> Polarity -> Polarity
forall a b. a -> b -> a
const) Gen a
g Step a
s

instance Integral a => Monoid (Step a) where
    mempty :: Step a
mempty = Step a
forall a. Step a
Empty
    mappend :: Step a -> Step a -> Step a
mappend = Step a -> Step a -> Step a
forall a. Semigroup a => a -> a -> a
(<>)




-- | Steps of many-at-a-time generators.
newtype MultiGen a = MultiGen { forall a. MultiGen a -> [Step a]
_mSteps :: [Step a] }
    deriving (MultiGen a -> MultiGen a -> Bool
(MultiGen a -> MultiGen a -> Bool)
-> (MultiGen a -> MultiGen a -> Bool) -> Eq (MultiGen a)
forall a. Eq a => MultiGen a -> MultiGen a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => MultiGen a -> MultiGen a -> Bool
== :: MultiGen a -> MultiGen a -> Bool
$c/= :: forall a. Eq a => MultiGen a -> MultiGen a -> Bool
/= :: MultiGen a -> MultiGen a -> Bool
Eq,NonEmpty (MultiGen a) -> MultiGen a
MultiGen a -> MultiGen a -> MultiGen a
(MultiGen a -> MultiGen a -> MultiGen a)
-> (NonEmpty (MultiGen a) -> MultiGen a)
-> (forall b. Integral b => b -> MultiGen a -> MultiGen a)
-> Semigroup (MultiGen a)
forall b. Integral b => b -> MultiGen a -> MultiGen a
forall a. NonEmpty (MultiGen a) -> MultiGen a
forall a. MultiGen a -> MultiGen a -> MultiGen a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall a b. Integral b => b -> MultiGen a -> MultiGen a
$c<> :: forall a. MultiGen a -> MultiGen a -> MultiGen a
<> :: MultiGen a -> MultiGen a -> MultiGen a
$csconcat :: forall a. NonEmpty (MultiGen a) -> MultiGen a
sconcat :: NonEmpty (MultiGen a) -> MultiGen a
$cstimes :: forall a b. Integral b => b -> MultiGen a -> MultiGen a
stimes :: forall b. Integral b => b -> MultiGen a -> MultiGen a
Semigroup,Semigroup (MultiGen a)
MultiGen a
Semigroup (MultiGen a) =>
MultiGen a
-> (MultiGen a -> MultiGen a -> MultiGen a)
-> ([MultiGen a] -> MultiGen a)
-> Monoid (MultiGen a)
[MultiGen a] -> MultiGen a
MultiGen a -> MultiGen a -> MultiGen a
forall a. Semigroup (MultiGen a)
forall a. MultiGen a
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall a. [MultiGen a] -> MultiGen a
forall a. MultiGen a -> MultiGen a -> MultiGen a
$cmempty :: forall a. MultiGen a
mempty :: MultiGen a
$cmappend :: forall a. MultiGen a -> MultiGen a -> MultiGen a
mappend :: MultiGen a -> MultiGen a -> MultiGen a
$cmconcat :: forall a. [MultiGen a] -> MultiGen a
mconcat :: [MultiGen a] -> MultiGen a
Monoid)
instance (Show a) => Show (MultiGen a) where show :: MultiGen a -> String
show (MultiGen [Step a]
s) = String
"MultiGen " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Step a] -> String
forall a. Show a => a -> String
show [Step a]
s
makeLenses ''MultiGen


-- | Braid with explicit dimensions (mainly for empty steps/strands)
data DimBraid b a =
    DimBraid { forall (b :: * -> *) a. DimBraid b a -> b a
_dBraid :: b a, forall (b :: * -> *) a. DimBraid b a -> Int
_dSteps :: Int, forall (b :: * -> *) a. DimBraid b a -> a
_dStrands :: a }
    deriving (DimBraid b a -> DimBraid b a -> Bool
(DimBraid b a -> DimBraid b a -> Bool)
-> (DimBraid b a -> DimBraid b a -> Bool) -> Eq (DimBraid b a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (b :: * -> *) a.
(Eq a, Eq (b a)) =>
DimBraid b a -> DimBraid b a -> Bool
$c== :: forall (b :: * -> *) a.
(Eq a, Eq (b a)) =>
DimBraid b a -> DimBraid b a -> Bool
== :: DimBraid b a -> DimBraid b a -> Bool
$c/= :: forall (b :: * -> *) a.
(Eq a, Eq (b a)) =>
DimBraid b a -> DimBraid b a -> Bool
/= :: DimBraid b a -> DimBraid b a -> Bool
Eq,Int -> DimBraid b a -> ShowS
[DimBraid b a] -> ShowS
DimBraid b a -> String
(Int -> DimBraid b a -> ShowS)
-> (DimBraid b a -> String)
-> ([DimBraid b a] -> ShowS)
-> Show (DimBraid b a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (b :: * -> *) a.
(Show a, Show (b a)) =>
Int -> DimBraid b a -> ShowS
forall (b :: * -> *) a.
(Show a, Show (b a)) =>
[DimBraid b a] -> ShowS
forall (b :: * -> *) a.
(Show a, Show (b a)) =>
DimBraid b a -> String
$cshowsPrec :: forall (b :: * -> *) a.
(Show a, Show (b a)) =>
Int -> DimBraid b a -> ShowS
showsPrec :: Int -> DimBraid b a -> ShowS
$cshow :: forall (b :: * -> *) a.
(Show a, Show (b a)) =>
DimBraid b a -> String
show :: DimBraid b a -> String
$cshowList :: forall (b :: * -> *) a.
(Show a, Show (b a)) =>
[DimBraid b a] -> ShowS
showList :: [DimBraid b a] -> ShowS
Show)
instance (Semigroup (b a), Integral a) => Semigroup (DimBraid b a) where
  (DimBraid b a
b1 Int
x1 a
y1) <> :: DimBraid b a -> DimBraid b a -> DimBraid b a
<> (DimBraid b a
b2 Int
x2 a
y2) =
        b a -> Int -> a -> DimBraid b a
forall (b :: * -> *) a. b a -> Int -> a -> DimBraid b a
DimBraid (b a
b1 b a -> b a -> b a
forall a. Semigroup a => a -> a -> a
<> b a
b2) (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
x1 Int
x2) (a
y1 a -> a -> a
forall a. Num a => a -> a -> a
+ a
y2)
instance (Monoid (b a), Semigroup (b a), Integral a) => Monoid (DimBraid b a) where
    mempty :: DimBraid b a
mempty = b a -> Int -> a -> DimBraid b a
forall (b :: * -> *) a. b a -> Int -> a -> DimBraid b a
DimBraid b a
forall a. Monoid a => a
mempty Int
0 a
0
    mappend :: DimBraid b a -> DimBraid b a -> DimBraid b a
mappend = DimBraid b a -> DimBraid b a -> DimBraid b a
forall a. Semigroup a => a -> a -> a
(<>)
makeLenses ''DimBraid

-- | Make 'DimBraid' using braid's dimensions.
dim :: (Braid b a) => b a -> DimBraid b a
dim :: forall (b :: * -> *) a. Braid b a => b a -> DimBraid b a
dim b a
b = b a -> Int -> a -> DimBraid b a
forall (b :: * -> *) a. b a -> Int -> a -> DimBraid b a
DimBraid b a
b (b a -> Int
forall (br :: * -> *) a. Braid br a => br a -> Int
stepCount b a
b) (b a -> a
forall (br :: * -> *) a. Braid br a => br a -> a
strandCount b a
b)




-- | Braid representations.
class (Integral a, Monoid (br a), Semigroup (br a)) => Braid br a where

    {-# MINIMAL toGens,minIndex,maxIndex,invert #-}

    -- | "Length", number of "steps"/columns/artin generators.
    stepCount :: br a -> Int
    -- | "N", braid group index, number of strands/rows/"i"s.
    strandCount :: br a -> a
    -- | Common format is br series of "steps" of absolute-indexed generators.
    toGens :: br a -> [[Gen a]]
    -- | Minimum index (i) value
    minIndex :: br a -> a
    -- | Maximum index (i) value. Note this means values of (i+1) obtain, per generators.
    maxIndex :: br a -> a
    -- | Invert indices
    invert :: br a -> br a
    -- | convert to single-gen
    toArtin :: br a -> Artin a
    -- | convert to multi-gen
    toMultiGen :: br a -> MultiGen a

    strandCount br a
br = (br a -> a
forall (br :: * -> *) a. Braid br a => br a -> a
maxIndex br a
br a -> a -> a
forall a. Num a => a -> a -> a
+ a
2) a -> a -> a
forall a. Num a => a -> a -> a
- br a -> a
forall (br :: * -> *) a. Braid br a => br a -> a
minIndex br a
br

    stepCount = [[Gen a]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([[Gen a]] -> Int) -> (br a -> [[Gen a]]) -> br a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. br a -> [[Gen a]]
forall (br :: * -> *) a. Braid br a => br a -> [[Gen a]]
toGens -- inefficient

    toArtin = [Gen a] -> Artin a
forall a. [Gen a] -> Artin a
Artin ([Gen a] -> Artin a) -> (br a -> [Gen a]) -> br a -> Artin a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Gen a]] -> [Gen a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Gen a]] -> [Gen a]) -> (br a -> [[Gen a]]) -> br a -> [Gen a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. br a -> [[Gen a]]
forall (br :: * -> *) a. Braid br a => br a -> [[Gen a]]
toGens

    toMultiGen = [Step a] -> MultiGen a
forall a. [Step a] -> MultiGen a
MultiGen ([Step a] -> MultiGen a)
-> (br a -> [Step a]) -> br a -> MultiGen a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Gen a] -> Step a) -> [[Gen a]] -> [Step a]
forall a b. (a -> b) -> [a] -> [b]
map [Gen a] -> Step a
forall a. Integral a => [Gen a] -> Step a
gensToStep ([[Gen a]] -> [Step a]) -> (br a -> [[Gen a]]) -> br a -> [Step a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. br a -> [[Gen a]]
forall (br :: * -> *) a. Braid br a => br a -> [[Gen a]]
toGens




instance Integral a => Braid Artin a where
    toGens :: Artin a -> [[Gen a]]
toGens = (Gen a -> [Gen a]) -> [Gen a] -> [[Gen a]]
forall a b. (a -> b) -> [a] -> [b]
map Gen a -> [Gen a]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Gen a] -> [[Gen a]])
-> (Artin a -> [Gen a]) -> Artin a -> [[Gen a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Artin a -> [Gen a]
forall a. Artin a -> [Gen a]
_aGens
    stepCount :: Artin a -> Int
stepCount = [Gen a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Gen a] -> Int) -> (Artin a -> [Gen a]) -> Artin a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Artin a -> [Gen a]
forall a. Artin a -> [Gen a]
_aGens
    minIndex :: Artin a -> a
minIndex (Artin []) = a
0
    minIndex Artin a
b = Artin a -> a
forall a. Ord a => Artin a -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum Artin a
b
    maxIndex :: Artin a -> a
maxIndex (Artin []) = a
0
    maxIndex Artin a
b = Artin a -> a
forall a. Ord a => Artin a -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum Artin a
b
    invert :: Artin a -> Artin a
invert Artin a
b = ASetter (Artin a) (Artin a) a a -> (a -> a) -> Artin a -> Artin a
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (([Gen a] -> Identity [Gen a]) -> Artin a -> Identity (Artin a)
forall a a (p :: * -> * -> *) (f :: * -> *).
(Profunctor p, Functor f) =>
p [Gen a] (f [Gen a]) -> p (Artin a) (f (Artin a))
aGens(([Gen a] -> Identity [Gen a]) -> Artin a -> Identity (Artin a))
-> ((a -> Identity a) -> [Gen a] -> Identity [Gen a])
-> ASetter (Artin a) (Artin a) a a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Gen a -> Identity (Gen a)) -> [Gen a] -> Identity [Gen a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse((Gen a -> Identity (Gen a)) -> [Gen a] -> Identity [Gen a])
-> ((a -> Identity a) -> Gen a -> Identity (Gen a))
-> (a -> Identity a)
-> [Gen a]
-> Identity [Gen a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(a -> Identity a) -> Gen a -> Identity (Gen a)
forall a a (f :: * -> *).
Functor f =>
(a -> f a) -> Gen a -> f (Gen a)
gPos) (Artin a -> a
forall (br :: * -> *) a. Braid br a => br a -> a
maxIndex Artin a
b a -> a -> a
forall a. Num a => a -> a -> a
-) Artin a
b
    toArtin :: Artin a -> Artin a
toArtin = Artin a -> Artin a
forall a. a -> a
id

instance Integral a => Braid MultiGen a where
    toGens :: MultiGen a -> [[Gen a]]
toGens = (Step a -> [Gen a]) -> [Step a] -> [[Gen a]]
forall a b. (a -> b) -> [a] -> [b]
map Step a -> [Gen a]
forall a. Integral a => Step a -> [Gen a]
stepToGens ([Step a] -> [[Gen a]])
-> (MultiGen a -> [Step a]) -> MultiGen a -> [[Gen a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MultiGen a -> [Step a]
forall a. MultiGen a -> [Step a]
_mSteps
    stepCount :: MultiGen a -> Int
stepCount = [Step a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Step a] -> Int) -> (MultiGen a -> [Step a]) -> MultiGen a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MultiGen a -> [Step a]
forall a. MultiGen a -> [Step a]
_mSteps
    minIndex :: MultiGen a -> a
minIndex = [a] -> a
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([a] -> a) -> (MultiGen a -> [a]) -> MultiGen a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Gen a -> a) -> [Gen a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map Gen a -> a
forall a. Gen a -> a
_gPos ([Gen a] -> [a]) -> (MultiGen a -> [Gen a]) -> MultiGen a -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Gen a]] -> [Gen a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Gen a]] -> [Gen a])
-> (MultiGen a -> [[Gen a]]) -> MultiGen a -> [Gen a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MultiGen a -> [[Gen a]]
forall (br :: * -> *) a. Braid br a => br a -> [[Gen a]]
toGens
    maxIndex :: MultiGen a -> a
maxIndex = [a] -> a
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([a] -> a) -> (MultiGen a -> [a]) -> MultiGen a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Gen a -> a) -> [Gen a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map Gen a -> a
forall a. Gen a -> a
_gPos ([Gen a] -> [a]) -> (MultiGen a -> [Gen a]) -> MultiGen a -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Gen a]] -> [Gen a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Gen a]] -> [Gen a])
-> (MultiGen a -> [[Gen a]]) -> MultiGen a -> [Gen a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MultiGen a -> [[Gen a]]
forall (br :: * -> *) a. Braid br a => br a -> [[Gen a]]
toGens
    invert :: MultiGen a -> MultiGen a
invert MultiGen a
b = ASetter (MultiGen a) (MultiGen a) (Step a) (Step a)
-> (Step a -> Step a) -> MultiGen a -> MultiGen a
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (([Step a] -> Identity [Step a])
-> MultiGen a -> Identity (MultiGen a)
forall a a (p :: * -> * -> *) (f :: * -> *).
(Profunctor p, Functor f) =>
p [Step a] (f [Step a]) -> p (MultiGen a) (f (MultiGen a))
mSteps(([Step a] -> Identity [Step a])
 -> MultiGen a -> Identity (MultiGen a))
-> ((Step a -> Identity (Step a)) -> [Step a] -> Identity [Step a])
-> ASetter (MultiGen a) (MultiGen a) (Step a) (Step a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Step a -> Identity (Step a)) -> [Step a] -> Identity [Step a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse) (a -> Step a -> Step a
forall a. Integral a => a -> Step a -> Step a
invertS (a -> Step a -> Step a) -> a -> Step a -> Step a
forall a b. (a -> b) -> a -> b
$ MultiGen a -> a
forall (br :: * -> *) a. Braid br a => br a -> a
maxIndex MultiGen a
b) MultiGen a
b
    toMultiGen :: MultiGen a -> MultiGen a
toMultiGen = MultiGen a -> MultiGen a
forall a. a -> a
id

instance (Integral a, Braid b a) => Braid (DimBraid b) a where
    toGens :: DimBraid b a -> [[Gen a]]
toGens DimBraid b a
b = [[Gen a]]
gs [[Gen a]] -> [[Gen a]] -> [[Gen a]]
forall a. [a] -> [a] -> [a]
++ [[Gen a]]
pad where
        gs :: [[Gen a]]
gs = b a -> [[Gen a]]
forall (br :: * -> *) a. Braid br a => br a -> [[Gen a]]
toGens (b a -> [[Gen a]]) -> b a -> [[Gen a]]
forall a b. (a -> b) -> a -> b
$ DimBraid b a -> b a
forall (b :: * -> *) a. DimBraid b a -> b a
_dBraid DimBraid b a
b
        pad :: [[Gen a]]
pad = Int -> [Gen a] -> [[Gen a]]
forall a. Int -> a -> [a]
replicate (DimBraid b a -> Int
forall (br :: * -> *) a. Braid br a => br a -> Int
stepCount DimBraid b a
b Int -> Int -> Int
forall a. Num a => a -> a -> a
- [[Gen a]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Gen a]]
gs) []
    stepCount :: DimBraid b a -> Int
stepCount DimBraid b a
b = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (DimBraid b a -> Int
forall (b :: * -> *) a. DimBraid b a -> Int
_dSteps DimBraid b a
b) (b a -> Int
forall (br :: * -> *) a. Braid br a => br a -> Int
stepCount (b a -> Int) -> b a -> Int
forall a b. (a -> b) -> a -> b
$ DimBraid b a -> b a
forall (b :: * -> *) a. DimBraid b a -> b a
_dBraid DimBraid b a
b)
    strandCount :: DimBraid b a -> a
strandCount DimBraid b a
b = a -> a -> a
forall a. Ord a => a -> a -> a
max (DimBraid b a -> a
forall (b :: * -> *) a. DimBraid b a -> a
_dStrands DimBraid b a
b) (b a -> a
forall (br :: * -> *) a. Braid br a => br a -> a
strandCount (b a -> a) -> b a -> a
forall a b. (a -> b) -> a -> b
$ DimBraid b a -> b a
forall (b :: * -> *) a. DimBraid b a -> b a
_dBraid DimBraid b a
b)
    minIndex :: DimBraid b a -> a
minIndex = b a -> a
forall (br :: * -> *) a. Braid br a => br a -> a
minIndex (b a -> a) -> (DimBraid b a -> b a) -> DimBraid b a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DimBraid b a -> b a
forall (b :: * -> *) a. DimBraid b a -> b a
_dBraid
    maxIndex :: DimBraid b a -> a
maxIndex DimBraid b a
b = DimBraid b a -> a
forall (br :: * -> *) a. Braid br a => br a -> a
minIndex DimBraid b a
b a -> a -> a
forall a. Num a => a -> a -> a
+ DimBraid b a -> a
forall (br :: * -> *) a. Braid br a => br a -> a
strandCount DimBraid b a
b a -> a -> a
forall a. Num a => a -> a -> a
- a
2
    invert :: DimBraid b a -> DimBraid b a
invert = ASetter (DimBraid b a) (DimBraid b a) (b a) (b a)
-> (b a -> b a) -> DimBraid b a -> DimBraid b a
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter (DimBraid b a) (DimBraid b a) (b a) (b a)
forall (b :: * -> *) a (b :: * -> *) (f :: * -> *).
Functor f =>
(b a -> f (b a)) -> DimBraid b a -> f (DimBraid b a)
dBraid b a -> b a
forall (br :: * -> *) a. Braid br a => br a -> br a
invert

-- | Instruction to send the value "over" or "under" to the next value in
-- a 'Strand' or 'Loop'. Newtyping is undesirable, want to keep Pair instances.
type Weave a = (a,Polarity)

-- | Extract a list of weaves.
class ToWeaves w a where
    toWeaves :: w -> [Weave a]
instance ToWeaves [Weave a] a where
    toWeaves :: [Weave a] -> [Weave a]
toWeaves = [Weave a] -> [Weave a]
forall a. a -> a
id

-- | Concrete braid strand presentation as values delimited
-- by polarities.
data Strand a = Strand { forall a. Strand a -> [Weave a]
_sWeaves :: [Weave a], forall a. Strand a -> a
_sLast :: a }
              deriving (Strand a -> Strand a -> Bool
(Strand a -> Strand a -> Bool)
-> (Strand a -> Strand a -> Bool) -> Eq (Strand a)
forall a. Eq a => Strand a -> Strand a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Strand a -> Strand a -> Bool
== :: Strand a -> Strand a -> Bool
$c/= :: forall a. Eq a => Strand a -> Strand a -> Bool
/= :: Strand a -> Strand a -> Bool
Eq,Int -> Strand a -> ShowS
[Strand a] -> ShowS
Strand a -> String
(Int -> Strand a -> ShowS)
-> (Strand a -> String) -> ([Strand a] -> ShowS) -> Show (Strand a)
forall a. Show a => Int -> Strand a -> ShowS
forall a. Show a => [Strand a] -> ShowS
forall a. Show a => Strand a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Strand a -> ShowS
showsPrec :: Int -> Strand a -> ShowS
$cshow :: forall a. Show a => Strand a -> String
show :: Strand a -> String
$cshowList :: forall a. Show a => [Strand a] -> ShowS
showList :: [Strand a] -> ShowS
Show)
makeLenses ''Strand
instance ToWeaves (Strand a) a where
    toWeaves :: Strand a -> [Weave a]
toWeaves = Strand a -> [Weave a]
forall a. Strand a -> [Weave a]
_sWeaves
instance Functor Strand where
    fmap :: forall a b. (a -> b) -> Strand a -> Strand b
fmap a -> b
f (Strand [Weave a]
ss a
l) = [Weave b] -> b -> Strand b
forall a. [Weave a] -> a -> Strand a
Strand ((Weave a -> Weave b) -> [Weave a] -> [Weave b]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> b) -> Weave a -> Weave b
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first a -> b
f) [Weave a]
ss) (a -> b
f a
l)
instance Foldable Strand where
    foldMap :: forall m a. Monoid m => (a -> m) -> Strand a -> m
foldMap a -> m
f (Strand [Weave a]
ss a
l) = (a -> m) -> [a] -> m
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f ((Weave a -> a) -> [Weave a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map Weave a -> a
forall a b. (a, b) -> a
fst [Weave a]
ss [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
l])
instance Traversable Strand where
    traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Strand a -> f (Strand b)
traverse a -> f b
f (Strand [Weave a]
ss a
l) =
        [Weave b] -> b -> Strand b
forall a. [Weave a] -> a -> Strand a
Strand ([Weave b] -> b -> Strand b) -> f [Weave b] -> f (b -> Strand b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Weave a -> f (Weave b)) -> [Weave a] -> f [Weave b]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (\(a
a,Polarity
p)->(,) (b -> Polarity -> Weave b) -> f b -> f (Polarity -> Weave b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
a f (Polarity -> Weave b) -> f Polarity -> f (Weave b)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Polarity -> f Polarity
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Polarity
p) [Weave a]
ss f (b -> Strand b) -> f b -> f (Strand b)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> f b
f a
l




-- | Extract a single strand from a braid.
strand :: (Integral a, Braid b a) => a -> b a -> Strand a
strand :: forall a (b :: * -> *).
(Integral a, Braid b a) =>
a -> b a -> Strand a
strand a
a = a -> [[Gen a]] -> Strand a
forall a. Integral a => a -> [[Gen a]] -> Strand a
strand' a
a ([[Gen a]] -> Strand a) -> (b a -> [[Gen a]]) -> b a -> Strand a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b a -> [[Gen a]]
forall (br :: * -> *) a. Braid br a => br a -> [[Gen a]]
toGens

-- | Strand from gen matrix.
strand' :: Integral a => a -> [[Gen a]] -> Strand a
strand' :: forall a. Integral a => a -> [[Gen a]] -> Strand a
strand' a
a = (Strand a -> [Gen a] -> Strand a)
-> Strand a -> [[Gen a]] -> Strand a
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Strand a -> [Gen a] -> Strand a
forall {a}. (Eq a, Enum a) => Strand a -> [Gen a] -> Strand a
srch ([Weave a] -> a -> Strand a
forall a. [Weave a] -> a -> Strand a
Strand [] a
a) where
    srch :: Strand a -> [Gen a] -> Strand a
srch (Strand [Weave a]
ss a
l) [Gen a]
gs = case a -> [Gen a] -> Maybe (Weave a)
forall {t}. (Eq t, Enum t) => t -> [Gen t] -> Maybe (t, Polarity)
lkp a
l [Gen a]
gs of
                              Just (a
n,Polarity
p) -> [Weave a] -> a -> Strand a
forall a. [Weave a] -> a -> Strand a
Strand ([Weave a]
ss [Weave a] -> [Weave a] -> [Weave a]
forall a. [a] -> [a] -> [a]
++ [(a
l,Polarity
p)]) a
n
                              Maybe (Weave a)
Nothing -> [Weave a] -> a -> Strand a
forall a. [Weave a] -> a -> Strand a
Strand ([Weave a]
ss [Weave a] -> [Weave a] -> [Weave a]
forall a. [a] -> [a] -> [a]
++ [(a
l,Polarity
O)]) a
l
    lkp :: t -> [Gen t] -> Maybe (t, Polarity)
lkp t
_ [] = Maybe (t, Polarity)
forall a. Maybe a
Nothing
    lkp t
l (Gen t
i Polarity
p:[Gen t]
gs) | t
l t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
i = (t, Polarity) -> Maybe (t, Polarity)
forall a. a -> Maybe a
Just (t -> t
forall a. Enum a => a -> a
succ t
l,Polarity -> Polarity
complement Polarity
p)
                         | t
l t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t -> t
forall a. Enum a => a -> a
succ t
i = (t, Polarity) -> Maybe (t, Polarity)
forall a. a -> Maybe a
Just (t -> t
forall a. Enum a => a -> a
pred t
l,Polarity
p)
                         | Bool
otherwise = t -> [Gen t] -> Maybe (t, Polarity)
lkp t
l [Gen t]
gs

-- | Extract all strands from a braid.
strands :: (Integral a, Braid b a) => b a -> [Strand a]
strands :: forall a (b :: * -> *).
(Integral a, Braid b a) =>
b a -> [Strand a]
strands b a
b = (a -> Strand a) -> [a] -> [Strand a]
forall a b. (a -> b) -> [a] -> [b]
map (a -> [[Gen a]] -> Strand a
forall a. Integral a => a -> [[Gen a]] -> Strand a
`strand'` b a -> [[Gen a]]
forall (br :: * -> *) a. Braid br a => br a -> [[Gen a]]
toGens b a
b) [b a -> a
forall (br :: * -> *) a. Braid br a => br a -> a
minIndex b a
b..a -> a
forall a. Enum a => a -> a
succ (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ b a -> a
forall (br :: * -> *) a. Braid br a => br a -> a
maxIndex b a
b]

-- | Capture strands into a loop, where '_sLast' of one strand
-- is the first value of the next.
-- Foldable instance ignores "last" values of strands (since they will equal the next head).
newtype Loop a = Loop { forall a. Loop a -> [Strand a]
_lStrands :: [Strand a] }
            deriving (Loop a -> Loop a -> Bool
(Loop a -> Loop a -> Bool)
-> (Loop a -> Loop a -> Bool) -> Eq (Loop a)
forall a. Eq a => Loop a -> Loop a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Loop a -> Loop a -> Bool
== :: Loop a -> Loop a -> Bool
$c/= :: forall a. Eq a => Loop a -> Loop a -> Bool
/= :: Loop a -> Loop a -> Bool
Eq,Int -> Loop a -> ShowS
[Loop a] -> ShowS
Loop a -> String
(Int -> Loop a -> ShowS)
-> (Loop a -> String) -> ([Loop a] -> ShowS) -> Show (Loop a)
forall a. Show a => Int -> Loop a -> ShowS
forall a. Show a => [Loop a] -> ShowS
forall a. Show a => Loop a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Loop a -> ShowS
showsPrec :: Int -> Loop a -> ShowS
$cshow :: forall a. Show a => Loop a -> String
show :: Loop a -> String
$cshowList :: forall a. Show a => [Loop a] -> ShowS
showList :: [Loop a] -> ShowS
Show,NonEmpty (Loop a) -> Loop a
Loop a -> Loop a -> Loop a
(Loop a -> Loop a -> Loop a)
-> (NonEmpty (Loop a) -> Loop a)
-> (forall b. Integral b => b -> Loop a -> Loop a)
-> Semigroup (Loop a)
forall b. Integral b => b -> Loop a -> Loop a
forall a. NonEmpty (Loop a) -> Loop a
forall a. Loop a -> Loop a -> Loop a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall a b. Integral b => b -> Loop a -> Loop a
$c<> :: forall a. Loop a -> Loop a -> Loop a
<> :: Loop a -> Loop a -> Loop a
$csconcat :: forall a. NonEmpty (Loop a) -> Loop a
sconcat :: NonEmpty (Loop a) -> Loop a
$cstimes :: forall a b. Integral b => b -> Loop a -> Loop a
stimes :: forall b. Integral b => b -> Loop a -> Loop a
Semigroup,Semigroup (Loop a)
Loop a
Semigroup (Loop a) =>
Loop a
-> (Loop a -> Loop a -> Loop a)
-> ([Loop a] -> Loop a)
-> Monoid (Loop a)
[Loop a] -> Loop a
Loop a -> Loop a -> Loop a
forall a. Semigroup (Loop a)
forall a. Loop a
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall a. [Loop a] -> Loop a
forall a. Loop a -> Loop a -> Loop a
$cmempty :: forall a. Loop a
mempty :: Loop a
$cmappend :: forall a. Loop a -> Loop a -> Loop a
mappend :: Loop a -> Loop a -> Loop a
$cmconcat :: forall a. [Loop a] -> Loop a
mconcat :: [Loop a] -> Loop a
Monoid,(forall a b. (a -> b) -> Loop a -> Loop b)
-> (forall a b. a -> Loop b -> Loop a) -> Functor Loop
forall a b. a -> Loop b -> Loop a
forall a b. (a -> b) -> Loop a -> Loop b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Loop a -> Loop b
fmap :: forall a b. (a -> b) -> Loop a -> Loop b
$c<$ :: forall a b. a -> Loop b -> Loop a
<$ :: forall a b. a -> Loop b -> Loop a
Functor)
makeLenses ''Loop

instance Foldable Loop where
    foldMap :: forall m a. Monoid m => (a -> m) -> Loop a -> m
foldMap a -> m
f = (a -> m) -> [a] -> m
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f ([a] -> m) -> (Loop a -> [a]) -> Loop a -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Endo [a]) (Loop a) a -> Loop a -> [a]
forall a s. Getting (Endo [a]) s a -> s -> [a]
toListOf (([Strand a] -> Const (Endo [a]) [Strand a])
-> Loop a -> Const (Endo [a]) (Loop a)
forall a a (p :: * -> * -> *) (f :: * -> *).
(Profunctor p, Functor f) =>
p [Strand a] (f [Strand a]) -> p (Loop a) (f (Loop a))
lStrands(([Strand a] -> Const (Endo [a]) [Strand a])
 -> Loop a -> Const (Endo [a]) (Loop a))
-> ((a -> Const (Endo [a]) a)
    -> [Strand a] -> Const (Endo [a]) [Strand a])
-> Getting (Endo [a]) (Loop a) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Strand a -> Const (Endo [a]) (Strand a))
-> [Strand a] -> Const (Endo [a]) [Strand a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse((Strand a -> Const (Endo [a]) (Strand a))
 -> [Strand a] -> Const (Endo [a]) [Strand a])
-> ((a -> Const (Endo [a]) a)
    -> Strand a -> Const (Endo [a]) (Strand a))
-> (a -> Const (Endo [a]) a)
-> [Strand a]
-> Const (Endo [a]) [Strand a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.([Weave a] -> Const (Endo [a]) [Weave a])
-> Strand a -> Const (Endo [a]) (Strand a)
forall a (f :: * -> *).
Functor f =>
([Weave a] -> f [Weave a]) -> Strand a -> f (Strand a)
sWeaves(([Weave a] -> Const (Endo [a]) [Weave a])
 -> Strand a -> Const (Endo [a]) (Strand a))
-> ((a -> Const (Endo [a]) a)
    -> [Weave a] -> Const (Endo [a]) [Weave a])
-> (a -> Const (Endo [a]) a)
-> Strand a
-> Const (Endo [a]) (Strand a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Weave a -> Const (Endo [a]) (Weave a))
-> [Weave a] -> Const (Endo [a]) [Weave a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse((Weave a -> Const (Endo [a]) (Weave a))
 -> [Weave a] -> Const (Endo [a]) [Weave a])
-> ((a -> Const (Endo [a]) a)
    -> Weave a -> Const (Endo [a]) (Weave a))
-> (a -> Const (Endo [a]) a)
-> [Weave a]
-> Const (Endo [a]) [Weave a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(a -> Const (Endo [a]) a) -> Weave a -> Const (Endo [a]) (Weave a)
forall s t a b. Field1 s t a b => Lens s t a b
Lens (Weave a) (Weave a) a a
_1)
instance ToWeaves (Loop a) a where
    toWeaves :: Loop a -> [Weave a]
toWeaves = Getting (Endo [Weave a]) (Loop a) (Weave a) -> Loop a -> [Weave a]
forall a s. Getting (Endo [a]) s a -> s -> [a]
toListOf (([Strand a] -> Const (Endo [Weave a]) [Strand a])
-> Loop a -> Const (Endo [Weave a]) (Loop a)
forall a a (p :: * -> * -> *) (f :: * -> *).
(Profunctor p, Functor f) =>
p [Strand a] (f [Strand a]) -> p (Loop a) (f (Loop a))
lStrands(([Strand a] -> Const (Endo [Weave a]) [Strand a])
 -> Loop a -> Const (Endo [Weave a]) (Loop a))
-> ((Weave a -> Const (Endo [Weave a]) (Weave a))
    -> [Strand a] -> Const (Endo [Weave a]) [Strand a])
-> Getting (Endo [Weave a]) (Loop a) (Weave a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Strand a -> Const (Endo [Weave a]) (Strand a))
-> [Strand a] -> Const (Endo [Weave a]) [Strand a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse((Strand a -> Const (Endo [Weave a]) (Strand a))
 -> [Strand a] -> Const (Endo [Weave a]) [Strand a])
-> ((Weave a -> Const (Endo [Weave a]) (Weave a))
    -> Strand a -> Const (Endo [Weave a]) (Strand a))
-> (Weave a -> Const (Endo [Weave a]) (Weave a))
-> [Strand a]
-> Const (Endo [Weave a]) [Strand a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.([Weave a] -> Const (Endo [Weave a]) [Weave a])
-> Strand a -> Const (Endo [Weave a]) (Strand a)
forall a (f :: * -> *).
Functor f =>
([Weave a] -> f [Weave a]) -> Strand a -> f (Strand a)
sWeaves(([Weave a] -> Const (Endo [Weave a]) [Weave a])
 -> Strand a -> Const (Endo [Weave a]) (Strand a))
-> ((Weave a -> Const (Endo [Weave a]) (Weave a))
    -> [Weave a] -> Const (Endo [Weave a]) [Weave a])
-> (Weave a -> Const (Endo [Weave a]) (Weave a))
-> Strand a
-> Const (Endo [Weave a]) (Strand a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Weave a -> Const (Endo [Weave a]) (Weave a))
-> [Weave a] -> Const (Endo [Weave a]) [Weave a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse)




-- | Find loops in strands.
toLoops :: (Eq a,Show a) => [Strand a] -> [Loop a]
toLoops :: forall a. (Eq a, Show a) => [Strand a] -> [Loop a]
toLoops [] = []
toLoops [Strand a]
sa = [Loop a] -> [Loop a]
forall a. [a] -> [a]
reverse ([Loop a] -> [Loop a]) -> [Loop a] -> [Loop a]
forall a b. (a -> b) -> a -> b
$
             ASetter [Loop a] [Loop a] [Strand a] [Strand a]
-> ([Strand a] -> [Strand a]) -> [Loop a] -> [Loop a]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((Loop a -> Identity (Loop a)) -> [Loop a] -> Identity [Loop a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse((Loop a -> Identity (Loop a)) -> [Loop a] -> Identity [Loop a])
-> (([Strand a] -> Identity [Strand a])
    -> Loop a -> Identity (Loop a))
-> ASetter [Loop a] [Loop a] [Strand a] [Strand a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.([Strand a] -> Identity [Strand a]) -> Loop a -> Identity (Loop a)
forall a a (p :: * -> * -> *) (f :: * -> *).
(Profunctor p, Functor f) =>
p [Strand a] (f [Strand a]) -> p (Loop a) (f (Loop a))
lStrands) (\[Strand a]
s -> [Strand a] -> Strand a
forall a. HasCallStack => [a] -> a
last [Strand a]
sStrand a -> [Strand a] -> [Strand a]
forall a. a -> [a] -> [a]
:[Strand a] -> [Strand a]
forall a. HasCallStack => [a] -> [a]
init [Strand a]
s) ([Loop a] -> [Loop a]) -> [Loop a] -> [Loop a]
forall a b. (a -> b) -> a -> b
$
             [Loop a] -> [Strand a] -> [Loop a]
forall {b}. (Eq b, Show b) => [Loop b] -> [Strand b] -> [Loop b]
recurL [] [Strand a]
sa where
    shead :: Strand c -> c
shead = (c, Polarity) -> c
forall a b. (a, b) -> a
fst ((c, Polarity) -> c)
-> (Strand c -> (c, Polarity)) -> Strand c -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(c, Polarity)] -> (c, Polarity)
forall a. HasCallStack => [a] -> a
head ([(c, Polarity)] -> (c, Polarity))
-> (Strand c -> [(c, Polarity)]) -> Strand c -> (c, Polarity)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Strand c -> [(c, Polarity)]
forall a. Strand a -> [Weave a]
_sWeaves
    findTail :: [Strand b] -> Strand b -> Bool
findTail [Strand b]
s = (b -> b -> Bool
forall a. Eq a => a -> a -> Bool
==Strand b -> b
forall a. Strand a -> a
shead ([Strand b] -> Strand b
forall a. HasCallStack => [a] -> a
head [Strand b]
s)) (b -> Bool) -> (Strand b -> b) -> Strand b -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Strand b -> b
forall a. Strand a -> a
_sLast
    recurL :: [Loop b] -> [Strand b] -> [Loop b]
recurL [Loop b]
ls [] = [Loop b]
ls
    recurL [Loop b]
ls (Strand b
a:[Strand b]
as) = [Strand b] -> [Strand b] -> [Loop b]
recurS [Strand b
a] [Strand b]
as
        where recurS :: [Strand b] -> [Strand b] -> [Loop b]
recurS [Strand b]
s [Strand b]
ss =
                  case (Strand b -> Bool) -> [Strand b] -> [Strand b]
forall a. (a -> Bool) -> [a] -> [a]
filter ([Strand b] -> Strand b -> Bool
forall {b}. Eq b => [Strand b] -> Strand b -> Bool
findTail [Strand b]
s) [Strand b]
ss of
                    [] -> [Loop b] -> [Strand b] -> [Loop b]
recurL ([Strand b] -> Loop b
forall a. [Strand a] -> Loop a
Loop [Strand b]
sLoop b -> [Loop b] -> [Loop b]
forall a. a -> [a] -> [a]
:[Loop b]
ls) [Strand b]
ss
                    [Strand b
t] -> [Strand b] -> [Strand b] -> [Loop b]
recurS (Strand b
tStrand b -> [Strand b] -> [Strand b]
forall a. a -> [a] -> [a]
:[Strand b]
s) ((Strand b -> Bool) -> [Strand b] -> [Strand b]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Strand b -> Bool) -> Strand b -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Strand b] -> Strand b -> Bool
forall {b}. Eq b => [Strand b] -> Strand b -> Bool
findTail [Strand b]
s) [Strand b]
ss)
                    [Strand b]
ts -> String -> [Loop b]
forall a. HasCallStack => String -> a
error (String -> [Loop b]) -> String -> [Loop b]
forall a b. (a -> b) -> a -> b
$ String
"More than one strand found with same tail: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Strand b] -> String
forall a. Show a => a -> String
show [Strand b]
ts


-- | A la Reidemeister.
data Move b i = Move (b i) (b i)
    deriving (Move b i -> Move b i -> Bool
(Move b i -> Move b i -> Bool)
-> (Move b i -> Move b i -> Bool) -> Eq (Move b i)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (b :: * -> *) i. Eq (b i) => Move b i -> Move b i -> Bool
$c== :: forall (b :: * -> *) i. Eq (b i) => Move b i -> Move b i -> Bool
== :: Move b i -> Move b i -> Bool
$c/= :: forall (b :: * -> *) i. Eq (b i) => Move b i -> Move b i -> Bool
/= :: Move b i -> Move b i -> Bool
Eq,Int -> Move b i -> ShowS
[Move b i] -> ShowS
Move b i -> String
(Int -> Move b i -> ShowS)
-> (Move b i -> String) -> ([Move b i] -> ShowS) -> Show (Move b i)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (b :: * -> *) i. Show (b i) => Int -> Move b i -> ShowS
forall (b :: * -> *) i. Show (b i) => [Move b i] -> ShowS
forall (b :: * -> *) i. Show (b i) => Move b i -> String
$cshowsPrec :: forall (b :: * -> *) i. Show (b i) => Int -> Move b i -> ShowS
showsPrec :: Int -> Move b i -> ShowS
$cshow :: forall (b :: * -> *) i. Show (b i) => Move b i -> String
show :: Move b i -> String
$cshowList :: forall (b :: * -> *) i. Show (b i) => [Move b i] -> ShowS
showList :: [Move b i] -> ShowS
Show)
instance Field1 (Move b i) (Move b i) (b i) (b i) where
    _1 :: Lens (Move b i) (Move b i) (b i) (b i)
_1 b i -> f (b i)
f (Move b i
a b i
b) = (b i -> b i -> Move b i
forall (b :: * -> *) i. b i -> b i -> Move b i
`Move` b i
b) (b i -> Move b i) -> f (b i) -> f (Move b i)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b i -> f (b i)
f b i
a
instance Field2 (Move b i) (Move b i) (b i) (b i) where
    _2 :: Lens (Move b i) (Move b i) (b i) (b i)
_2 b i -> f (b i)
f (Move b i
a b i
b) = b i -> b i -> Move b i
forall (b :: * -> *) i. b i -> b i -> Move b i
Move b i
a (b i -> Move b i) -> f (b i) -> f (Move b i)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b i -> f (b i)
f b i
b

-- | Flip a move
inverse :: Move b i -> Move b i
inverse :: forall (b :: * -> *) i. Move b i -> Move b i
inverse (Move b i
a b i
b) = b i -> b i -> Move b i
forall (b :: * -> *) i. b i -> b i -> Move b i
Move b i
b b i
a

-- | Move "height" or strand count
moveH :: Braid a i => Move a i -> i
moveH :: forall (a :: * -> *) i. Braid a i => Move a i -> i
moveH (Move a i
m1 a i
m2) = i -> i -> i
forall a. Ord a => a -> a -> a
max (a i -> i
forall (br :: * -> *) a. Braid br a => br a -> a
strandCount a i
m1) (i -> i) -> i -> i
forall a b. (a -> b) -> a -> b
$ a i -> i
forall (br :: * -> *) a. Braid br a => br a -> a
strandCount a i
m2
-- | Move "width" or step count
moveW :: Braid a i => Move a i -> Int
moveW :: forall (a :: * -> *) i. Braid a i => Move a i -> Int
moveW (Move a i
m1 a i
m2) = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (a i -> Int
forall (br :: * -> *) a. Braid br a => br a -> Int
stepCount a i
m1) (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ a i -> Int
forall (br :: * -> *) a. Braid br a => br a -> Int
stepCount a i
m2

-- | Coordinate in braid.
data Loc a = Loc { forall a. Loc a -> Int
_lx :: Int, forall a. Loc a -> a
_ly :: a } deriving (Loc a -> Loc a -> Bool
(Loc a -> Loc a -> Bool) -> (Loc a -> Loc a -> Bool) -> Eq (Loc a)
forall a. Eq a => Loc a -> Loc a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Loc a -> Loc a -> Bool
== :: Loc a -> Loc a -> Bool
$c/= :: forall a. Eq a => Loc a -> Loc a -> Bool
/= :: Loc a -> Loc a -> Bool
Eq,Int -> Loc a -> ShowS
[Loc a] -> ShowS
Loc a -> String
(Int -> Loc a -> ShowS)
-> (Loc a -> String) -> ([Loc a] -> ShowS) -> Show (Loc a)
forall a. Show a => Int -> Loc a -> ShowS
forall a. Show a => [Loc a] -> ShowS
forall a. Show a => Loc a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Loc a -> ShowS
showsPrec :: Int -> Loc a -> ShowS
$cshow :: forall a. Show a => Loc a -> String
show :: Loc a -> String
$cshowList :: forall a. Show a => [Loc a] -> ShowS
showList :: [Loc a] -> ShowS
Show,Eq (Loc a)
Eq (Loc a) =>
(Loc a -> Loc a -> Ordering)
-> (Loc a -> Loc a -> Bool)
-> (Loc a -> Loc a -> Bool)
-> (Loc a -> Loc a -> Bool)
-> (Loc a -> Loc a -> Bool)
-> (Loc a -> Loc a -> Loc a)
-> (Loc a -> Loc a -> Loc a)
-> Ord (Loc a)
Loc a -> Loc a -> Bool
Loc a -> Loc a -> Ordering
Loc a -> Loc a -> Loc a
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 a. Ord a => Eq (Loc a)
forall a. Ord a => Loc a -> Loc a -> Bool
forall a. Ord a => Loc a -> Loc a -> Ordering
forall a. Ord a => Loc a -> Loc a -> Loc a
$ccompare :: forall a. Ord a => Loc a -> Loc a -> Ordering
compare :: Loc a -> Loc a -> Ordering
$c< :: forall a. Ord a => Loc a -> Loc a -> Bool
< :: Loc a -> Loc a -> Bool
$c<= :: forall a. Ord a => Loc a -> Loc a -> Bool
<= :: Loc a -> Loc a -> Bool
$c> :: forall a. Ord a => Loc a -> Loc a -> Bool
> :: Loc a -> Loc a -> Bool
$c>= :: forall a. Ord a => Loc a -> Loc a -> Bool
>= :: Loc a -> Loc a -> Bool
$cmax :: forall a. Ord a => Loc a -> Loc a -> Loc a
max :: Loc a -> Loc a -> Loc a
$cmin :: forall a. Ord a => Loc a -> Loc a -> Loc a
min :: Loc a -> Loc a -> Loc a
Ord)
makeLenses ''Loc
instance Field1 (Loc a) (Loc a) Int Int where
    _1 :: Lens (Loc a) (Loc a) Int Int
_1 Int -> f Int
f (Loc Int
a a
b) = (Int -> a -> Loc a
forall a. Int -> a -> Loc a
`Loc` a
b) (Int -> Loc a) -> f Int -> f (Loc a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> f Int
f Int
a
instance Field2 (Loc a) (Loc a) a a where
    _2 :: Lens (Loc a) (Loc a) a a
_2 a -> f a
f (Loc Int
a a
b) = Int -> a -> Loc a
forall a. Int -> a -> Loc a
Loc Int
a (a -> Loc a) -> f a -> f (Loc a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f a
f a
b