{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Braids represented as Haskell types with support for generation and transformations.
--
-- = Braid Typeclass
--
-- `Braid` is a typeclass over the braid rep itself and its value type. Since a goal of this library is to use braids for non-mathematical purposes (ie music composition), a Braid can be indexed over any `Integral` type, to support braids representing pitch values in a register for instance.
--
-- = Generators
--
-- All braids are represented using Artin generators as `Gen`, with `Polarity` defining the "power" of a generator as `O`ver or `U`nder.
--
-- Generator indexes are usually 0-indexed, which differs from the 1-indexed generators in the literature. However, again these braids can represent other ranges of numbers as branch indexes.
--
-- = Braid instances
--
-- `Artin` creates canonical, "one-at-a-time", generator braids.
--
-- @
-- Artin [Gen 0 O,Gen 1 U]
-- @
--
-- `MultiGen` creates "compressed", "many-at-a-time" braids of `Step`s, which
-- prevent invalid adjacent generators.
--
-- @
-- MultiGen [Step (Gen 1 U) [Gen 0 U],Step (Gen 1 O) []]
-- @
--
-- `DimBraid` is for creating "padded" braids, since generators cannot express the absence of a cross.
--
-- = Birman\/Ko\/Lee generators.
--
-- `bandGen` creates Birman\/Ko\/Lee-style band generators.
--
-- = Transformations\/Moves
--
-- In addition to operations like `merge` etc, the type `Move` represents Reidemeister-type isotopy moves. `makeTree` unfolds a potentially-infinite tree representing all possible applications of a move.
--
-- = Graphics
--
-- `renderBraid`, `renderBraids` and `renderStrand` allow drawings of braids, admitting extra functions for colorizing etc.
--
-- @
-- renderBraid 60 [colorStrands] "braid.png" $ bandGen 0 5
-- @
--
-- <<http://i.imgur.com/JsK2D1p.png>>
--
--
module Fadno.Braids
    (
    -- * Braid Types
     module Fadno.Braids.Internal
    -- * Braid find\/merge\/clear
     ,find,find',merge,mergeAt,mergeAt',clear,clearMerge
    -- * Isotopy\/Reidemeister moves
      ,reidemeister2,reidemeister3,findMoves,applyMove,moves,makeTree
    -- * Band generators
     ,bandGen
    -- * Braid Graphics
    ,module Fadno.Braids.Graphics
    ) where
import Control.Lens hiding (op,(#),Empty)
import Fadno.Braids.Internal
import Fadno.Braids.Graphics
import Data.Tree
import Data.Default






-- | Birman, Ko, Lee "band generators" (sigma-s-t)
bandGen :: Integral a => a -> a -> Artin a
bandGen :: forall a. Integral a => a -> a -> Artin a
bandGen a
s a
t | a
s a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
t = [Char] -> Artin a
forall a. HasCallStack => [Char] -> a
error [Char]
"invalid, s >= t"
            | Bool
otherwise = [Gen a] -> Artin a
forall a. [Gen a] -> Artin a
Artin ([Gen a] -> Artin a) -> [Gen a] -> Artin a
forall a b. (a -> b) -> a -> b
$
                          (a -> Gen a) -> [a] -> [Gen a]
forall a b. (a -> b) -> [a] -> [b]
map (a -> Polarity -> Gen a
forall a. a -> Polarity -> Gen a
`Gen` Polarity
O) ([a] -> [a]
forall a. [a] -> [a]
reverse [a
s a -> a -> a
forall a. Num a => a -> a -> a
+ a
1 .. a
t a -> a -> a
forall a. Num a => a -> a -> a
- a
1]) [Gen a] -> [Gen a] -> [Gen a]
forall a. [a] -> [a] -> [a]
++
                          [a -> Polarity -> Gen a
forall a. a -> Polarity -> Gen a
Gen a
s Polarity
O] [Gen a] -> [Gen a] -> [Gen a]
forall a. [a] -> [a] -> [a]
++
                          (a -> Gen a) -> [a] -> [Gen a]
forall a b. (a -> b) -> [a] -> [b]
map (a -> Polarity -> Gen a
forall a. a -> Polarity -> Gen a
`Gen` Polarity
U) [a
s a -> a -> a
forall a. Num a => a -> a -> a
+ a
1 .. a
t a -> a -> a
forall a. Num a => a -> a -> a
- a
1]


-- | Merge one braid into another at offsets.
mergeAt :: (Integral a, Braid b a) => Int -> a -> b a -> b a -> MultiGen a
mergeAt :: forall a (b :: * -> *).
(Integral a, Braid b a) =>
Int -> a -> b a -> b a -> MultiGen a
mergeAt Int
x a
y b a
ba b a
bb = Int -> a -> [[Gen a]] -> [[Gen a]] -> MultiGen a
forall a.
Integral a =>
Int -> a -> [[Gen a]] -> [[Gen a]] -> MultiGen a
mergeAt' Int
x a
y (b a -> [[Gen a]]
forall (br :: * -> *) a. Braid br a => br a -> [[Gen a]]
toGens b a
ba) (b a -> [[Gen a]]
forall (br :: * -> *) a. Braid br a => br a -> [[Gen a]]
toGens b a
bb)

-- | Matrix version.
mergeAt' :: forall a . (Integral a) => Int -> a -> [[Gen a]] -> [[Gen a]] -> MultiGen a
mergeAt' :: forall a.
Integral a =>
Int -> a -> [[Gen a]] -> [[Gen a]] -> MultiGen a
mergeAt' Int
x a
y [[Gen a]]
ba [[Gen a]]
bb = [Step a] -> MultiGen a
forall a. [Step a] -> MultiGen a
MultiGen ([Step a] -> MultiGen a) -> [Step a] -> MultiGen a
forall a b. (a -> b) -> a -> b
$ [[Gen a]] -> [[Gen a]] -> [Step a]
loop ([[Gen a]] -> [[Gen a]]
offset [[Gen a]]
ba) [[Gen a]]
bb
    where loop :: [[Gen a]] -> [[Gen a]] -> [Step a]
          loop :: [[Gen a]] -> [[Gen a]] -> [Step a]
loop [] [] = []
          loop ([Gen a]
a:[[Gen a]]
as) [] = [Gen a] -> Step a
forall a. Integral a => [Gen a] -> Step a
gensToStep [Gen a]
aStep a -> [Step a] -> [Step a]
forall a. a -> [a] -> [a]
:[[Gen a]] -> [[Gen a]] -> [Step a]
loop [[Gen a]]
as []
          loop [] ([Gen a]
b:[[Gen a]]
bs) = [Gen a] -> Step a
forall a. Integral a => [Gen a] -> Step a
gensToStep [Gen a]
bStep a -> [Step a] -> [Step a]
forall a. a -> [a] -> [a]
:[[Gen a]] -> [[Gen a]] -> [Step a]
loop [] [[Gen a]]
bs
          loop ([Gen a]
a:[[Gen a]]
as) ([Gen a]
b:[[Gen a]]
bs) = (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) ([Gen a] -> Step a
forall a. Integral a => [Gen a] -> Step a
gensToStep [Gen a]
a) [Gen a]
bStep a -> [Step a] -> [Step a]
forall a. a -> [a] -> [a]
:[[Gen a]] -> [[Gen a]] -> [Step a]
loop [[Gen a]]
as [[Gen a]]
bs
          offset :: [[Gen a]] -> [[Gen a]]
offset [[Gen a]]
gens = Int -> [Gen a] -> [[Gen a]]
forall a. Int -> a -> [a]
replicate Int
x [] [[Gen a]] -> [[Gen a]] -> [[Gen a]]
forall a. [a] -> [a] -> [a]
++ a -> [[Gen a]] -> [[Gen a]]
forall a. Integral a => a -> [[Gen a]] -> [[Gen a]]
offsetGenVals a
y [[Gen a]]
gens

offsetGenVals :: Integral a => a -> [[Gen a]] -> [[Gen a]]
offsetGenVals :: forall a. Integral a => a -> [[Gen a]] -> [[Gen a]]
offsetGenVals a
y = ([Gen a] -> [Gen a]) -> [[Gen a]] -> [[Gen a]]
forall a b. (a -> b) -> [a] -> [b]
map ((Gen a -> Gen a) -> [Gen a] -> [Gen a]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> a) -> Gen a -> Gen a
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> a -> a
forall a. Num a => a -> a -> a
+a
y)))

normalGenVals :: Integral a => [[Gen a]] -> [[Gen a]]
normalGenVals :: forall a. Integral a => [[Gen a]] -> [[Gen a]]
normalGenVals [[Gen a]]
gs = a -> [[Gen a]] -> [[Gen a]]
forall a. Integral a => a -> [[Gen a]] -> [[Gen a]]
offsetGenVals (- ([a] -> a
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([a] -> a) -> ([Gen a] -> [a]) -> [Gen 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) -> [Gen a] -> a
forall a b. (a -> b) -> a -> b
$ [[Gen a]] -> [Gen a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Gen a]]
gs)) [[Gen a]]
gs

-- | Rectangular gen eraser.
clear :: Integral a => Int -> a -> Int -> a -> [[Gen a]] -> [[Gen a]]
clear :: forall a.
Integral a =>
Int -> a -> Int -> a -> [[Gen a]] -> [[Gen a]]
clear Int
x a
y Int
w a
h = Int -> [[Gen a]] -> [[Gen a]]
clrx Int
0 where
    clrx :: Int -> [[Gen a]] -> [[Gen a]]
clrx Int
_ [] = []
    clrx Int
xi ([Gen a]
s:[[Gen a]]
ss) = (if Int
xi Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
x Bool -> Bool -> Bool
&& Int
xi Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
w then [Gen a] -> [Gen a]
clry [Gen a]
s else [Gen a]
s)[Gen a] -> [[Gen a]] -> [[Gen a]]
forall a. a -> [a] -> [a]
:Int -> [[Gen a]] -> [[Gen a]]
clrx (Int -> Int
forall a. Enum a => a -> a
succ Int
xi) [[Gen a]]
ss
    clry :: [Gen a] -> [Gen a]
clry [] = []
    clry (g :: Gen a
g@(Gen a
i Polarity
_):[Gen a]
gs) | a
i a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
y Bool -> Bool -> Bool
&& a
i a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
y a -> a -> a
forall a. Num a => a -> a -> a
+ a
h = [Gen a] -> [Gen a]
clry [Gen a]
gs
                          | Bool
otherwise = Gen a
gGen a -> [Gen a] -> [Gen a]
forall a. a -> [a] -> [a]
:[Gen a] -> [Gen a]
clry [Gen a]
gs


-- | Merge one braid into another.
merge :: forall b a . (Integral a, Braid b a) => b a -> b a -> MultiGen a
merge :: forall (b :: * -> *) a.
(Integral a, Braid b a) =>
b a -> b a -> MultiGen a
merge = Int -> a -> b a -> b a -> MultiGen a
forall a (b :: * -> *).
(Integral a, Braid b a) =>
Int -> a -> b a -> b a -> MultiGen a
mergeAt Int
0 a
0

_bands :: MultiGen Int
_bands :: MultiGen Int
_bands = Int -> Int -> Artin Int -> Artin Int -> MultiGen Int
forall a (b :: * -> *).
(Integral a, Braid b a) =>
Int -> a -> b a -> b a -> MultiGen a
mergeAt Int
5 Int
5 (Int -> Int -> Artin Int
forall a. Integral a => a -> a -> Artin a
bandGen Int
0 Int
4) (Int -> Int -> Artin Int
forall a. Integral a => a -> a -> Artin a
bandGen Int
0 Int
9)


_testpath :: FilePath
_testpath :: [Char]
_testpath = [Char]
"output/test.png"

-- renderBraid :: Braid b a => Int -> [BraidDrawF a] -> FilePath -> b a -> IO ()

_drawLoops,_drawStrands :: (Show a, Integral a, Braid b a) => b a -> IO ()
_drawLoops :: forall a (b :: * -> *).
(Show a, Integral a, Braid b a) =>
b a -> IO ()
_drawLoops = DrawConf -> [BraidDrawF a] -> [Char] -> b a -> IO ()
forall (b :: * -> *) a.
Braid b a =>
DrawConf -> [BraidDrawF a] -> [Char] -> b a -> IO ()
renderBraid DrawConf
forall a. Default a => a
def { stepWidth = 400 } [BraidDrawF a
forall a. (Eq a, Show a) => BraidDrawF a
colorLoops] [Char]
_testpath
_drawStrands :: forall a (b :: * -> *).
(Show a, Integral a, Braid b a) =>
b a -> IO ()
_drawStrands = DrawConf -> [BraidDrawF a] -> [Char] -> b a -> IO ()
forall (b :: * -> *) a.
Braid b a =>
DrawConf -> [BraidDrawF a] -> [Char] -> b a -> IO ()
renderBraid DrawConf
forall a. Default a => a
def { stepWidth = 400 } [BraidDrawF a
forall a. BraidDrawF a
colorStrands] [Char]
_testpath




-- | Reidemeister move 2, [s1,s1^-1] === flat
reidemeister2 :: Integral a => Move Artin a
reidemeister2 :: forall a. Integral a => Move Artin a
reidemeister2 = Artin a -> Artin a -> Move Artin a
forall (b :: * -> *) i. b i -> b i -> Move b i
Move ([Gen a] -> Artin a
forall a. [Gen a] -> Artin a
Artin [a -> Polarity -> Gen a
forall a. a -> Polarity -> Gen a
Gen a
0 Polarity
O,a -> Polarity -> Gen a
forall a. a -> Polarity -> Gen a
Gen a
0 Polarity
U]) ([Gen a] -> Artin a
forall a. [Gen a] -> Artin a
Artin [])

-- | Reidemeister move 3, [s1,s2,s1^-1] === [s2^-1,s1,s2], and inverse polarity.
-- Rule: a pattern of [(i,p),(i',p),(i,^p)] moves to [(i',^p),(i,p),(i',p)],
-- where i' = i `op` i where op is plus or minus; with the reversed lists too.
reidemeister3 :: Integral a => [Move Artin a]
reidemeister3 :: forall a. Integral a => [Move Artin a]
reidemeister3 = [ [Gen a] -> Move Artin a
forall {a}. (Eq a, Num a) => [Gen a] -> Move Artin a
mk ((a -> Polarity -> Gen a) -> [a] -> [Polarity] -> [Gen a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> Polarity -> Gen a
forall a. a -> Polarity -> Gen a
Gen [a]
is [Polarity]
ps) | [Polarity]
ps <- [[Polarity
U,Polarity
U,Polarity
O],[Polarity
O,Polarity
O,Polarity
U]], [a]
is <- [[a
0,a
1,a
0],[a
1,a
0,a
1]]]
    where mk :: [Gen a] -> Move Artin a
mk [Gen a]
gs = Artin a -> Artin a -> Move Artin a
forall (b :: * -> *) i. b i -> b i -> Move b i
Move ([Gen a] -> Artin a
forall a. [Gen a] -> Artin a
Artin [Gen a]
gs) (Artin a -> Move Artin a) -> Artin a -> Move Artin a
forall a b. (a -> b) -> a -> b
$
                        [Gen a] -> Artin a
forall a. [Gen a] -> Artin a
Artin ([Gen a] -> Artin a) -> [Gen a] -> Artin a
forall a b. (a -> b) -> a -> b
$ 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 a1 a2 (f :: * -> *).
Functor f =>
(a1 -> f a2) -> Gen a1 -> f (Gen a2)
gPos)
                                  (\a
i -> if a
i a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 then a
1 else a
0) ([Gen a] -> [Gen a]
forall a. [a] -> [a]
reverse [Gen a]
gs)

_drawReid3s :: IO ()
_drawReid3s :: IO ()
_drawReid3s = DrawConf -> [BraidDrawF Int] -> [Char] -> [[Artin Int]] -> IO ()
forall (b :: * -> *) a.
Braid b a =>
DrawConf -> [BraidDrawF a] -> [Char] -> [[b a]] -> IO ()
renderBraids DrawConf
forall a. Default a => a
def { stepWidth = 80 } [BraidDrawF Int
forall a. BraidDrawF a
colorStrands] [Char]
"output/reid3.png" ([[Artin Int]] -> IO ()) -> [[Artin Int]] -> IO ()
forall a b. (a -> b) -> a -> b
$
             (Move Artin Int -> [Artin Int])
-> [Move Artin Int] -> [[Artin Int]]
forall a b. (a -> b) -> [a] -> [b]
map (\(Move Artin Int
a Artin Int
b) -> [Artin Int
a,Artin Int
b]) ([Move Artin Int]
forall a. Integral a => [Move Artin a]
reidemeister3 :: [Move Artin Int])


-- drawMove (last reidemeister3) bands
_drawMove :: (Integral i, Braid a i, Braid b i) => Move a i -> b i -> IO ()
_drawMove :: forall i (a :: * -> *) (b :: * -> *).
(Integral i, Braid a i, Braid b i) =>
Move a i -> b i -> IO ()
_drawMove Move a i
m b i
b = DrawConf -> [BraidDrawF i] -> [Char] -> [[MultiGen i]] -> IO ()
forall (b :: * -> *) a.
Braid b a =>
DrawConf -> [BraidDrawF a] -> [Char] -> [[b a]] -> IO ()
renderBraids DrawConf
forall a. Default a => a
def { stepWidth = 80 } [BraidDrawF i
forall a. BraidDrawF a
colorStrands] [Char]
"output/move.png"
               [b i -> MultiGen i
forall (br :: * -> *) a. Braid br a => br a -> MultiGen a
toMultiGen b i
bMultiGen i -> [MultiGen i] -> [MultiGen i]
forall a. a -> [a] -> [a]
:(a i -> MultiGen i) -> [a i] -> [MultiGen i]
forall a b. (a -> b) -> [a] -> [b]
map a i -> MultiGen i
forall (br :: * -> *) a. Braid br a => br a -> MultiGen a
toMultiGen [Getting (a i) (Move a i) (a i) -> Move a i -> a i
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (a i) (Move a i) (a i)
forall s t a b. Field1 s t a b => Lens s t a b
Lens (Move a i) (Move a i) (a i) (a i)
_1 Move a i
m, Getting (a i) (Move a i) (a i) -> Move a i -> a i
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (a i) (Move a i) (a i)
forall s t a b. Field2 s t a b => Lens s t a b
Lens (Move a i) (Move a i) (a i) (a i)
_2 Move a i
m],
                --[toMultiGen b],
                (Loc i -> MultiGen i) -> [Loc i] -> [MultiGen i]
forall a b. (a -> b) -> [a] -> [b]
map (\Loc i
l -> Move a i -> Loc i -> b i -> MultiGen i
forall i (a :: * -> *) (b :: * -> *).
(Integral i, Braid a i, Braid b i) =>
Move a i -> Loc i -> b i -> MultiGen i
applyMove Move a i
m Loc i
l b i
b) (Move a i -> b i -> [Loc i]
forall i (a :: * -> *) (b :: * -> *).
(Integral i, Braid a i, Braid b i) =>
Move a i -> b i -> [Loc i]
findMoves Move a i
m b i
b)]




-- | Find all locations of a sub-braid within a braid.
find :: (Integral i, Braid a i, Braid b i) => a i -> b i -> [Loc i]
find :: forall i (a :: * -> *) (b :: * -> *).
(Integral i, Braid a i, Braid b i) =>
a i -> b i -> [Loc i]
find a i
ba = [[Gen i]] -> Int -> i -> b i -> [Loc i]
forall i (b :: * -> *).
(Integral i, Braid b i) =>
[[Gen i]] -> Int -> i -> b i -> [Loc i]
find' ([[Gen i]] -> [[Gen i]]
forall a. Integral a => [[Gen a]] -> [[Gen a]]
normalGenVals ([[Gen i]] -> [[Gen i]]) -> [[Gen i]] -> [[Gen i]]
forall a b. (a -> b) -> a -> b
$ a i -> [[Gen i]]
forall (br :: * -> *) a. Braid br a => br a -> [[Gen a]]
toGens a i
ba) (a i -> Int
forall (br :: * -> *) a. Braid br a => br a -> Int
stepCount a i
ba) (a i -> i
forall (br :: * -> *) a. Braid br a => br a -> a
strandCount a i
ba)

-- | Find all locations of a sub-braid within a braid, matrix version.
find' :: (Integral i, Braid b i) => [[Gen i]] -> Int -> i -> b i -> [Loc i]
find' :: forall i (b :: * -> *).
(Integral i, Braid b i) =>
[[Gen i]] -> Int -> i -> b i -> [Loc i]
find' [[Gen i]]
ba Int
w i
h b i
bb = [ Int -> i -> Loc i
forall a. Int -> a -> Loc a
Loc Int
x i
y | Int
x <- [Int
0 .. b i -> Int
forall (br :: * -> *) a. Braid br a => br a -> Int
stepCount b i
bb] ,
                    i
y <- [b i -> i
forall (br :: * -> *) a. Braid br a => br a -> a
minIndex b i
bb .. b i -> i
forall (br :: * -> *) a. Braid br a => br a -> a
maxIndex b i
bb] ,
                    Int -> i -> Bool
test Int
x i
y ]
    where gba :: [[Gen i]]
gba = [[Gen i]] -> [[Gen i]]
forall a. Integral a => [[Gen a]] -> [[Gen a]]
normalGenVals [[Gen i]]
ba
          gbb :: [[Gen i]]
gbb = b i -> [[Gen i]]
forall (br :: * -> *) a. Braid br a => br a -> [[Gen a]]
toGens b i
bb
          test :: Int -> i -> Bool
test Int
x i
y = [[Gen i]]
gbb [[Gen i]] -> [[Gen i]] -> Bool
forall a. Eq a => a -> a -> Bool
== MultiGen i -> [[Gen i]]
forall (br :: * -> *) a. Braid br a => br a -> [[Gen a]]
toGens ([[Gen i]] -> Int -> i -> Int -> i -> [[Gen i]] -> MultiGen i
forall a.
Integral a =>
[[Gen a]] -> Int -> a -> Int -> a -> [[Gen a]] -> MultiGen a
clearMerge [[Gen i]]
gba Int
x i
y Int
w i
h [[Gen i]]
gbb)

-- | clear generators and merge. TODO: doesn't clear adjacent gens.
clearMerge :: Integral a =>
     [[Gen a]] -> Int -> a -> Int -> a -> [[Gen a]] -> MultiGen a
clearMerge :: forall a.
Integral a =>
[[Gen a]] -> Int -> a -> Int -> a -> [[Gen a]] -> MultiGen a
clearMerge [[Gen a]]
ba Int
x a
y Int
w a
h = Int -> a -> [[Gen a]] -> [[Gen a]] -> MultiGen a
forall a.
Integral a =>
Int -> a -> [[Gen a]] -> [[Gen a]] -> MultiGen a
mergeAt' Int
x a
y [[Gen a]]
ba ([[Gen a]] -> MultiGen a)
-> ([[Gen a]] -> [[Gen a]]) -> [[Gen a]] -> MultiGen a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a -> Int -> a -> [[Gen a]] -> [[Gen a]]
forall a.
Integral a =>
Int -> a -> Int -> a -> [[Gen a]] -> [[Gen a]]
clear Int
x a
y Int
w a
h

-- | Locates all move location in a braid.
findMoves :: (Integral i, Braid a i, Braid b i) => Move a i -> b i -> [Loc i]
findMoves :: forall i (a :: * -> *) (b :: * -> *).
(Integral i, Braid a i, Braid b i) =>
Move a i -> b i -> [Loc i]
findMoves m :: Move a i
m@(Move a i
m1 a i
_) = [[Gen i]] -> Int -> i -> b i -> [Loc i]
forall i (b :: * -> *).
(Integral i, Braid b i) =>
[[Gen i]] -> Int -> i -> b i -> [Loc i]
find' (a i -> [[Gen i]]
forall (br :: * -> *) a. Braid br a => br a -> [[Gen a]]
toGens a i
m1) (Move a i -> Int
forall (a :: * -> *) i. Braid a i => Move a i -> Int
moveW Move a i
m) (Move a i -> i
forall (a :: * -> *) i. Braid a i => Move a i -> i
moveH Move a i
m)


-- | Apply a move at a location.
applyMove :: (Integral i, Braid a i, Braid b i) => Move a i -> Loc i -> b i -> MultiGen i
applyMove :: forall i (a :: * -> *) (b :: * -> *).
(Integral i, Braid a i, Braid b i) =>
Move a i -> Loc i -> b i -> MultiGen i
applyMove m :: Move a i
m@(Move a i
_ a i
m2) (Loc Int
x i
y)  =
    [[Gen i]] -> Int -> i -> Int -> i -> [[Gen i]] -> MultiGen i
forall a.
Integral a =>
[[Gen a]] -> Int -> a -> Int -> a -> [[Gen a]] -> MultiGen a
clearMerge (a i -> [[Gen i]]
forall (br :: * -> *) a. Braid br a => br a -> [[Gen a]]
toGens a i
m2) Int
x i
y (Move a i -> Int
forall (a :: * -> *) i. Braid a i => Move a i -> Int
moveW Move a i
m) (Move a i -> i
forall (a :: * -> *) i. Braid a i => Move a i -> i
moveH Move a i
m) ([[Gen i]] -> MultiGen i)
-> (b i -> [[Gen i]]) -> b i -> MultiGen i
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b i -> [[Gen i]]
forall (br :: * -> *) a. Braid br a => br a -> [[Gen a]]
toGens

-- | Test a collection of moves against a braid and pair results with location.
moves :: (Integral i, Braid a i, Braid b i) => [Move a i] -> b i -> [(Move a i,[Loc i])]
moves :: forall i (a :: * -> *) (b :: * -> *).
(Integral i, Braid a i, Braid b i) =>
[Move a i] -> b i -> [(Move a i, [Loc i])]
moves [Move a i]
mvs b i
target = ((Move a i, [Loc i]) -> Bool)
-> [(Move a i, [Loc i])] -> [(Move a i, [Loc i])]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((Move a i, [Loc i]) -> Bool) -> (Move a i, [Loc i]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Loc i] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Loc i] -> Bool)
-> ((Move a i, [Loc i]) -> [Loc i]) -> (Move a i, [Loc i]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Move a i, [Loc i]) -> [Loc i]
forall a b. (a, b) -> b
snd) ([(Move a i, [Loc i])] -> [(Move a i, [Loc i])])
-> [(Move a i, [Loc i])] -> [(Move a i, [Loc i])]
forall a b. (a -> b) -> a -> b
$ (Move a i -> (Move a i, [Loc i]))
-> [Move a i] -> [(Move a i, [Loc i])]
forall a b. (a -> b) -> [a] -> [b]
map (\Move a i
m -> (Move a i
m, Move a i -> b i -> [Loc i]
forall i (a :: * -> *) (b :: * -> *).
(Integral i, Braid a i, Braid b i) =>
Move a i -> b i -> [Loc i]
findMoves Move a i
m b i
target)) [Move a i]
mvs


-- | Unfold a tree of all possible move applications on a braid.
-- A permutation is the permuted braid + the [(move,loc)]s that got us there.
-- Thus the root is (original braid, []); children are [(b1,(move,loc))].
makeTree :: (Integral i, Braid a i, Braid b i) =>
            [Move a i] -> b i -> Tree (MultiGen i,[(Move a i,Loc i)])
makeTree :: forall i (a :: * -> *) (b :: * -> *).
(Integral i, Braid a i, Braid b i) =>
[Move a i] -> b i -> Tree (MultiGen i, [(Move a i, Loc i)])
makeTree [Move a i]
mvs b i
org = ((MultiGen i, [(Move a i, Loc i)])
 -> ((MultiGen i, [(Move a i, Loc i)]),
     [(MultiGen i, [(Move a i, Loc i)])]))
-> (MultiGen i, [(Move a i, Loc i)])
-> Tree (MultiGen i, [(Move a i, Loc i)])
forall b a. (b -> (a, [b])) -> b -> Tree a
unfoldTree (MultiGen i, [(Move a i, Loc i)])
-> ((MultiGen i, [(Move a i, Loc i)]),
    [(MultiGen i, [(Move a i, Loc i)])])
go (b i -> MultiGen i
forall (br :: * -> *) a. Braid br a => br a -> MultiGen a
toMultiGen b i
org,[]) where
    go :: (MultiGen i, [(Move a i, Loc i)])
-> ((MultiGen i, [(Move a i, Loc i)]),
    [(MultiGen i, [(Move a i, Loc i)])])
go n :: (MultiGen i, [(Move a i, Loc i)])
n@(MultiGen i
seed,[(Move a i, Loc i)]
path) = ((MultiGen i, [(Move a i, Loc i)])
n,((Move a i, [Loc i]) -> [(MultiGen i, [(Move a i, Loc i)])])
-> [(Move a i, [Loc i])] -> [(MultiGen i, [(Move a i, Loc i)])]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (MultiGen i
-> [(Move a i, Loc i)]
-> (Move a i, [Loc i])
-> [(MultiGen i, [(Move a i, Loc i)])]
forall {i} {a :: * -> *} {b :: * -> *}.
(Braid a i, Braid b i) =>
b i
-> [(Move a i, Loc i)]
-> (Move a i, [Loc i])
-> [(MultiGen i, [(Move a i, Loc i)])]
gen MultiGen i
seed [(Move a i, Loc i)]
path) ([(Move a i, [Loc i])] -> [(MultiGen i, [(Move a i, Loc i)])])
-> [(Move a i, [Loc i])] -> [(MultiGen i, [(Move a i, Loc i)])]
forall a b. (a -> b) -> a -> b
$ [Move a i] -> MultiGen i -> [(Move a i, [Loc i])]
forall i (a :: * -> *) (b :: * -> *).
(Integral i, Braid a i, Braid b i) =>
[Move a i] -> b i -> [(Move a i, [Loc i])]
moves [Move a i]
mvs MultiGen i
seed)
    gen :: b i
-> [(Move a i, Loc i)]
-> (Move a i, [Loc i])
-> [(MultiGen i, [(Move a i, Loc i)])]
gen b i
target [(Move a i, Loc i)]
path (Move a i
mv,[Loc i]
locs) = (Loc i -> (MultiGen i, [(Move a i, Loc i)]))
-> [Loc i] -> [(MultiGen i, [(Move a i, Loc i)])]
forall a b. (a -> b) -> [a] -> [b]
map (\Loc i
l -> (Move a i -> Loc i -> b i -> MultiGen i
forall i (a :: * -> *) (b :: * -> *).
(Integral i, Braid a i, Braid b i) =>
Move a i -> Loc i -> b i -> MultiGen i
applyMove Move a i
mv Loc i
l b i
target,(Move a i
mv,Loc i
l)(Move a i, Loc i) -> [(Move a i, Loc i)] -> [(Move a i, Loc i)]
forall a. a -> [a] -> [a]
:[(Move a i, Loc i)]
path)) [Loc i]
locs


-- let t = makeTree reidemeister3 _bands
-- let t = makeTree (reidemeister3 ++ map inverse reidemeister3) _bands
-- renderBraids 100 [colorStrands] "allmoves.png" $ nub $ map (return.fst) $ flatten t

zipTail :: (a -> a -> c) -> [a] -> [c]
zipTail :: forall a c. (a -> a -> c) -> [a] -> [c]
zipTail a -> a -> c
f = (a -> a -> c) -> [a] -> [a] -> [c]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> a -> c
f ([a] -> [a] -> [c]) -> ([a] -> [a]) -> [a] -> [c]
forall a b. ([a] -> a -> b) -> ([a] -> a) -> [a] -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [a] -> [a]
forall a. HasCallStack => [a] -> [a]
tail