fadno-braids (empty) → 0.0.2
raw patch · 6 files changed
+803/−0 lines, 6 filesdep +basedep +containersdep +diagramssetup-changed
Dependencies added: base, containers, diagrams, diagrams-lib, diagrams-rasterific, lens, transformers-compat
Files
- LICENSE +26/−0
- Setup.hs +2/−0
- fadno-braids.cabal +32/−0
- src/Fadno/Braids.hs +215/−0
- src/Fadno/Braids/Graphics.hs +168/−0
- src/Fadno/Braids/Internal.hs +360/−0
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) 2015, Stuart Popejoy+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the+ distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ fadno-braids.cabal view
@@ -0,0 +1,32 @@+name: fadno-braids+category: Data, Math, Algebra+version: 0.0.2+synopsis: Braid representations in Haskell+description: Braids represented as Haskell types with support for generation and transformations.+homepage: http://github.com/slpopejoy/+license: BSD2+license-file: LICENSE+author: Stuart Popejoy+maintainer: spopejoy@panix.com+build-type: Simple+cabal-version: >=1.10+source-repository head+ type: git+ location: https://github.com/slpopejoy/fadno-braids.git++library+ exposed-modules:+ Fadno.Braids+ Fadno.Braids.Internal+ Fadno.Braids.Graphics+ -- other-modules:+ -- other-extensions:+ build-depends: base >=4.8 && <4.9+ , containers+ , lens == 4.13.*+ , diagrams == 1.3.*+ , diagrams-lib == 1.3.*+ , diagrams-rasterific == 1.3.*+ , transformers-compat == 0.4.*+ hs-source-dirs: src+ default-language: Haskell2010
+ src/Fadno/Braids.hs view
@@ -0,0 +1,215 @@+{-# 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+++++++-- | Birman, Ko, Lee "band generators" (sigma-s-t)+bandGen :: Integral a => a -> a -> Artin a+bandGen s t | s >= t = error "invalid, s >= t"+ | otherwise = Artin $+ map (`Gen` O) (reverse [s + 1 .. t - 1]) +++ [Gen s O] +++ map (`Gen` U) [s + 1 .. t - 1]+++-- | Merge one braid into another at offsets.+mergeAt :: (Integral a, Braid b a) => Int -> a -> b a -> b a -> MultiGen a+mergeAt x y ba bb = mergeAt' x y (toGens ba) (toGens bb)++-- | Matrix version.+mergeAt' :: forall a . (Integral a) => Int -> a -> [[Gen a]] -> [[Gen a]] -> MultiGen a+mergeAt' x y ba bb = MultiGen $ loop (offset ba) bb+ where loop :: [[Gen a]] -> [[Gen a]] -> [Step a]+ loop [] [] = []+ loop (a:as) [] = gensToStep a:loop as []+ loop [] (b:bs) = gensToStep b:loop [] bs+ loop (a:as) (b:bs) = foldl (flip insertS) (gensToStep a) b:loop as bs+ offset gens = replicate x [] ++ offsetGenVals y gens++offsetGenVals :: Integral a => a -> [[Gen a]] -> [[Gen a]]+offsetGenVals y = map (map (fmap (+y)))++normalGenVals :: Integral a => [[Gen a]] -> [[Gen a]]+normalGenVals gs = offsetGenVals (- (minimum . map _gPos $ concat gs)) gs++-- | Rectangular gen eraser.+clear :: Integral a => Int -> a -> Int -> a -> [[Gen a]] -> [[Gen a]]+clear x y w h = clrx 0 where+ clrx _ [] = []+ clrx xi (s:ss) = (if xi >= x && xi < x + w then clry s else s):clrx (succ xi) ss+ clry [] = []+ clry (g@(Gen i _):gs) | i >= y && i < y + h = clry gs+ | otherwise = g:clry gs+++-- | Merge one braid into another.+merge :: forall b a . (Integral a, Braid b a) => b a -> b a -> MultiGen a+merge = mergeAt 0 0++_bands :: MultiGen Int+_bands = mergeAt 5 5 (bandGen 0 4) (bandGen 0 9)+++_testpath :: FilePath+_testpath = "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 = renderBraid 400 [colorLoops] _testpath+_drawStrands = renderBraid 400 [colorStrands] _testpath+++++-- | Reidemeister move 2, [s1,s1^-1] === flat+reidemeister2 :: Integral a => Move Artin a+reidemeister2 = Move (Artin [Gen 0 O,Gen 0 U]) (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 = [ mk (zipWith Gen is ps) | ps <- [[U,U,O],[O,O,U]], is <- [[0,1,0],[1,0,1]]]+ where mk gs = Move (Artin gs) $+ Artin $ over (traverse.gPos)+ (\i -> if i == 0 then 1 else 0) (reverse gs)++_drawReid3s :: IO ()+_drawReid3s = renderBraids 80 [colorStrands] "output/reid3.png" $+ map (\(Move a b) -> [a,b]) (reidemeister3 :: [Move Artin Int])+++-- drawMove (last reidemeister3) bands+_drawMove :: (Integral i, Braid a i, Braid b i) => Move a i -> b i -> IO ()+_drawMove m b = renderBraids 80 [colorStrands] "output/move.png"+ [toMultiGen b:map toMultiGen [view _1 m, view _2 m],+ --[toMultiGen b],+ map (\l -> applyMove m l b) (findMoves m 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 ba = find' (normalGenVals $ toGens ba) (stepCount ba) (strandCount 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' ba w h bb = [ Loc x y | x <- [0 .. stepCount bb] ,+ y <- [minIndex bb .. maxIndex bb] ,+ test x y ]+ where gba = normalGenVals ba+ gbb = toGens bb+ test x y = gbb == toGens (clearMerge gba x y w h 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 ba x y w h = mergeAt' x y ba . clear x y w 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 m@(Move m1 _) = find' (toGens m1) (moveW m) (moveH 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 m@(Move _ m2) (Loc x y) =+ clearMerge (toGens m2) x y (moveW m) (moveH m) . 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 mvs target = filter (not . null . snd) $ map (\m -> (m, findMoves m target)) 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 mvs org = unfoldTree go (toMultiGen org,[]) where+ go n@(seed,path) = (n,concatMap (gen seed path) $ moves mvs seed)+ gen target path (mv,locs) = map (\l -> (applyMove mv l target,(mv,l):path)) 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 f = zipWith f <*> tail
+ src/Fadno/Braids/Graphics.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- | Diagrams for braids.+module Fadno.Braids.Graphics+ (+ renderBraid, BraidDrawF,+ renderStrand, StrandDrawF,+ colorStrands,colorLoops,+ gridStrand,renderBraids+ ) where++import Fadno.Braids.Internal+import Diagrams.Prelude hiding (Index,index,width,height,over,lw,Loop)+import Diagrams.Backend.Rasterific+import qualified Data.List as L+import Data.Maybe+++--+-- Braid Drawing+--++_aBraid :: Artin Integer+_aBraid = Artin [Gen 0 O,Gen 5 U,Gen 3 O, Gen 2 U,Gen 4 O]+_aStrand :: Strand Integer+_aStrand = head $ strands _aBraid++_testpath :: FilePath+_testpath = "output/test.png"++_testRenderB :: IO ()+_testRenderB = renderBraid 40 [colorStrands] _testpath _aBraid+_testRenderS :: IO ()+_testRenderS = renderStrand 40 [] _testpath crimson _aStrand++_testRendRast :: Diagram B -> IO ()+_testRendRast = renderRast _testpath 1000++-- | Draw rows and columns of braids with specified stepWidth and draw decorators.+renderBraids :: Braid b a => Int -> [BraidDrawF a] -> FilePath -> [[b a]] -> IO ()+renderBraids stepWidth drawFs fpath bs =+ renderRast fpath+ (stepWidth * maxWidth * maxCols)+ (reflectY $ bg white $ frame 0.2 $+ vcat $ map (hcat . map drawB) bs)+ where+ maxCols = maximum $ fmap length bs+ maxWidth = maximum $ fmap stepCount (concat bs)+ drawB = frame 0.8 . (`drawBraid` drawFs)++-- | Draw a braid with specified stepWidth and draw decorators.+renderBraid :: Braid b a => Int -> [BraidDrawF a] -> FilePath -> b a -> IO ()+renderBraid stepWidth drawFs fpath b =+ renderRast fpath (stepWidth * stepCount b) (reflectY $ bg white $ frame 0.4 $ drawBraid b drawFs)++-- | Draw a strand with specified stepWidth, color, and draw decorators.+renderStrand :: Integral a => Int -> [StrandDrawF a] -> FilePath -> Colour Double -> Strand a -> IO ()+renderStrand sw drawFs fp color s@(Strand ss _l) =+ renderRast fp (sw * (length ss + 1))+ (reflectY $ bg white $ frame 0.4 $+ runFs drawFs $ lwO 5 $ lc color $+ drawStrand s)+ where runFs = foldl1 (.) . map ($ s)++renderRast :: FilePath -> Int -> Diagram B -> IO ()+renderRast fpath imgWidth = renderRasterific fpath (mkWidth (fromIntegral imgWidth))++colors :: (Ord a, Floating a) => [Colour a]+colors = cycle [aqua, orange, deeppink, blueviolet, crimson, darkgreen, darkkhaki]++type Strand' a = [(a,Polarity,a)]++toStrand' :: Strand a -> Strand' a+toStrand' (Strand [] _) = []+toStrand' (Strand ss l) = zipWith (\(a,p) n -> (a,p,n)) ss (tail (map fst ss) ++ [l])++drawStrand :: Integral a => Strand a -> Diagram B+drawStrand s = foldMap (cap . fromVertices) $ foldl rs [[firstp (head ss)]] $+ zip [(0 :: Int)..] ss+ where+ ss = toStrand' s+ cap = lineCap LineCapButt+ firstp (y,_,_) = p2 (0,fromIntegral y)+ rs [] _ = error "No Pants!"+ rs (ps:pss) (x,(y,p,y')) | p == U = [pt 1,pt 0.6]:(pt 0.4:ps):pss+ | otherwise = (pt 1:ps):pss+ where pt = warpPt x y y'++warpPt :: Integral a => Int -> a -> a -> Double -> P2 Double+warpPt x y y' k = p2 (fromIntegral x + k, fromIntegral y `delt` k)+ where delt | y > y' = (-)+ | y < y' = (+)+ | otherwise = const+++-- | A function to affect strand presentation in a braid.+type BraidDrawF a = [Strand a] -> [Diagram B] -> [Diagram B]+-- | A function to affect strand presentation in a single-strand image.+type StrandDrawF a = Strand a -> Diagram B -> Diagram B++-- | Color a braid's strands separately.+colorStrands :: BraidDrawF a+colorStrands _ = zipWith lc colors++drawBraid :: Integral a => Braid b a => b a -> [BraidDrawF a] -> Diagram B+drawBraid b fs = mconcat $ runFs fs $ map (lwO 10 . drawStrand) ss+ where runFs = foldl1 (.) . map ($ ss)+ ss = strands b++-- | Color a braid's loops, such that looped strands have the same color.+colorLoops :: forall a . (Eq a,Show a) => BraidDrawF a+colorLoops ss = zipWith bs ss+ where loops = toLoops ss+ bs :: Strand a -> Diagram B -> Diagram B+ bs s = lc (colors !! seqidx)+ where seqidx = fromMaybe (error "invalid braid, strand not in seqs") $+ L.findIndex (elem s . _lStrands) loops++{-+labelIndex :: BraidDrawF+labelIndex (Braid _ _ _ idx _) = zipWith f (zip idx [0..]) where+ f :: (Int,Int) -> Diagram B -> Diagram B+ f (v,i) = (<> alignedText 1 0.5 (show v) #+ fontSize (local 0.35) #+ moveTo (p2 (-0.3,fromIntegral i)))++labelStrand :: StrandDrawF+labelStrand (Strand _ idx) dia = foldl f dia (zip idx [(0 :: Int)..])+ where f d (v,i) = d <> alignedText 1 0.5 (show v) #+ fontSize (local 0.35) #+ moveTo (p2 (-0.3,fromIntegral i))+-}++-- | Draw a grid behind a single strand.+gridStrand :: Integral a => StrandDrawF a+gridStrand s dia = (foldMap yl [0..fromIntegral yd] <>+ foldMap xl [0..xd])+ # lc lightgrey `beneath` dia+ where yl,xl :: Int -> Diagram B+ yl i = fromVertices [dp2 (0::Int,i), dp2 (xd,i)]+ xl i = fromVertices [dp2 (i,0::Int), dp2 (i,yd)]+ yd = maximum s - minimum s+ xd = length (_sWeaves s)++dp2 :: (Integral a, Integral a1, Num n) => (a, a1) -> P2 n+dp2 (a,b) = p2 (fromIntegral a, fromIntegral b)++{-+strandVertex :: StrandDrawF+strandVertex (Strand ss _) dia = foldMap f (zip ss [(0 :: Int)..]) <>+ lastDot (last ss) # lwO 2 <> dia+ where f ((v,w),i) | weft w /= UNDER = vdot i v+ | otherwise = mempty+ vdot :: Int -> Int -> Diagram B+ vdot i v = moveTo (dp2 (i,v)) $ fc black $ circle 0.1+ lastDot (v,w) = vdot (length ss) (warpf (warp w) v 1)++drawTerraceCol :: Int -> StrandDrawF+drawTerraceCol col (Strand ss idx) dia =+ dia <> mconcat (zipWith lc colors $ map (lwO 2 . step) $+ terracedCol False (length idx) (ss !! col))+ where step :: StrandStep -> Diagram B+ step (y,w) | weft w == UNDER = fromVertices [dp2(col,y),pt 0.4] <>+ fromVertices [pt 0.6, pt 1]+ | otherwise = fromVertices [dp2(col,y),pt 1]+ where pt = warpPt col y w++-}
+ src/Fadno/Braids/Internal.hs view
@@ -0,0 +1,360 @@+{-# 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++-- | 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 (Eq,Show,Enum,Ord)+++-- | Polarity to signum or "power" in literature.+power :: Integral a => Polarity -> a+power O = 1+power U = -1++-- | Flip polarity.+complement :: Polarity -> Polarity+complement O = U+complement U = O+++++-- | Braid generator pairing position (absolute or relative)+-- and polarity.+data Gen a = Gen { _gPos :: a, _gPol :: Polarity }+ deriving (Eq,Functor,Ord)+instance (Show a) => Show (Gen a) where+ show (Gen a pol) = "Gen " ++ show a ++ " " ++ show pol+makeLenses ''Gen+++-- | Braid as "Artin generators" (one-at-a-time).+newtype Artin a = Artin { _aGens :: [Gen a] }+ deriving (Eq,Show,Monoid,Functor)+instance Foldable Artin where+ foldMap f = foldMap f . map _gPos . _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+ _sHead :: Gen a+ -- | (offset + 2)-indexed tail generators.+ , _sOffsets :: [Gen Natural]+ } deriving (Eq)+makeLenses ''Step+instance Show a => Show (Step a) where+ show Empty = "Empty"+ show (Step h os) = "Step (" ++ show h ++ ") " ++ show 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 _ g Empty = Step g []+insertWithS f (Gen k p) s@(Step (Gen hi hp) sgs)+ | invalid hi = s+ | k < hi = Step (Gen k p) (Gen (fromIntegral $ hi - k - 2) hp:sgs)+ | k == hi = set (sHead.gPol) (f p hp) s+ | otherwise = set sOffsets (ins hi sgs) s+ where invalid i = k + 1 == i || i + 1 == k+ ins :: a -> [Gen Natural] -> [Gen Natural]+ ins i [] = [Gen (fromIntegral $ k - i - 2) p]+ ins i gss@(g@(Gen gi gp):gs)+ | invalid i' = gss+ | k < i' = Gen (fromIntegral $ k - i - 2) p:+ Gen (fromIntegral $ i' - k - 2) gp:gs+ | k == i' = set gPol (f p gp) g:gs+ | otherwise = g:ins i' gs+ where i' = i + fromIntegral gi + 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 = insertWithS const++-- | Lookup by absolute index in a 'Step'.+lookupS :: Integral a => a -> Step a -> Maybe Polarity+lookupS k = lkp . stepToGens where+ lkp [] = Nothing+ lkp (Gen a p:gs) | k == a = Just p+ | otherwise = lkp gs++-- | Delete/clear a gen at absolute index.+deleteS :: Integral a => a -> Step a -> Step a+deleteS a = gensToStep . del . stepToGens where+ del [] = []+ del (g@(Gen i _):gs) | a == i = gs+ | otherwise = g:del gs++++-- | translate 'Step' to absolute-indexed gens.+stepToGens :: Integral a => Step a -> [Gen a]+stepToGens Empty = []+stepToGens (Step h gs) = reverse $ foldl conv [h] gs+ where conv rs@(Gen p' _:_) (Gen p e) = Gen (fromIntegral p + p' + 2) e:rs+ conv _ _ = error "c'est impossible"++-- | translate absolute-indexed gens to 'Step'.+-- Drops invalid values.+gensToStep :: (Integral a) => [Gen a] -> Step a+gensToStep = foldl (flip insertS) Empty++-- | Iso for valid constructions.+stepGens :: Integral a => Iso' (Step a) [Gen a]+stepGens = iso stepToGens gensToStep+++invertS :: Integral a => a -> Step a -> Step a+invertS maxV = foldl (flip insertS) Empty . invGens . stepToGens+ where invGens = over (traverse.gPos) (maxV -)++++++type instance Index (Step a) = a+type instance IxValue (Step a) = Polarity+instance Integral a => Ixed (Step a) where+ ix k f m = case lookupS k m of+ Just v -> f v <&> \v' -> insertS (Gen k v') m+ Nothing -> pure m+ {-# INLINE ix #-}++instance Integral a => Monoid (Step a) where+ mempty = Empty+ a `mappend` b = foldl ins a (stepToGens b)+ where ins s g = insertWithS (flip const) g s+++++-- | Steps of many-at-a-time generators.+newtype MultiGen a = MultiGen { _mSteps :: [Step a] }+ deriving (Eq,Monoid)+instance (Show a) => Show (MultiGen a) where show (MultiGen s) = "MultiGen " ++ show s+makeLenses ''MultiGen+++-- | Braid with explicit dimensions (mainly for empty steps/strands)+data DimBraid b a =+ DimBraid { _dBraid :: b a, _dSteps :: Int, _dStrands :: a }+ deriving (Eq,Show)+instance (Monoid (b a), Integral a) => Monoid (DimBraid b a) where+ mempty = DimBraid mempty 0 0+ (DimBraid b1 x1 y1) `mappend` (DimBraid b2 x2 y2) =+ DimBraid (b1 `mappend` b2) (max x1 x2) (y1 + y2)+makeLenses ''DimBraid++-- | Make 'DimBraid' using braid's dimensions.+dim :: (Braid b a) => b a -> DimBraid b a+dim b = DimBraid b (stepCount b) (strandCount b)+++++-- | Braid representations.+class (Integral b, Monoid (a b)) => Braid (a :: * -> *) b where++ {-# MINIMAL toGens,minIndex,maxIndex,invert #-}++ -- | "Length", number of "steps"/columns/artin generators.+ stepCount :: a b -> Int+ -- | "N", braid group index, number of strands/rows/"i"s.+ strandCount :: a b -> b+ -- | Common format is a series of "steps" of absolute-indexed generators.+ toGens :: a b -> [[Gen b]]+ -- | Minimum index (i) value+ minIndex :: a b -> b+ -- | Maximum index (i) value. Note this means values of (i+1) obtain, per generators.+ maxIndex :: a b -> b+ -- | Invert indices+ invert :: a b -> a b+ -- | convert to single-gen+ toArtin :: a b -> Artin b+ -- | convert to multi-gen+ toMultiGen :: a b -> MultiGen b++ strandCount a = (maxIndex a + 2) - minIndex a++ stepCount = length . toGens -- inefficient++ toArtin = Artin . concat . toGens++ toMultiGen = MultiGen . map gensToStep . toGens+++++instance Integral a => Braid (Artin) a where+ toGens = map return . _aGens+ stepCount = length . _aGens+ minIndex (Artin []) = 0+ minIndex b = minimum b+ maxIndex (Artin []) = 0+ maxIndex b = maximum b+ invert b = over (aGens.traverse.gPos) (maxIndex b -) b+ toArtin = id++instance Integral a => Braid (MultiGen) a where+ toGens = map stepToGens . _mSteps+ stepCount = length . _mSteps+ minIndex = minimum . map _gPos . concat . toGens+ maxIndex = maximum . map _gPos . concat . toGens+ invert b = over (mSteps.traverse) (invertS $ maxIndex b) b+ toMultiGen = id++instance (Integral a, Braid b a) => Braid (DimBraid b) a where+ toGens b = gs ++ pad where+ gs = toGens $ _dBraid b+ pad = replicate (stepCount b - length gs) []+ stepCount b = max (_dSteps b) (stepCount $ _dBraid b)+ strandCount b = max (_dStrands b) (strandCount $ _dBraid b)+ minIndex = minIndex . _dBraid+ maxIndex b = minIndex b + strandCount b - 2+ invert = over dBraid 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 = id++-- | Concrete braid strand presentation as values delimited+-- by polarities.+data Strand a = Strand { _sWeaves :: [Weave a], _sLast :: a }+ deriving (Eq,Show)+makeLenses ''Strand+instance ToWeaves (Strand a) a where+ toWeaves = _sWeaves+instance Functor Strand where+ fmap f (Strand ss l) = Strand (map (first f) ss) (f l)+instance Foldable Strand where+ foldMap f (Strand ss l) = foldMap f (map fst ss ++ [l])+instance Traversable Strand where+ traverse f (Strand ss l) =+ Strand <$> traverse (\(a,p)->(,) <$> f a <*> pure p) ss <*> f l+++++-- | Extract a single strand from a braid.+strand :: (Integral a, Braid b a) => a -> b a -> Strand a+strand a = strand' a . toGens++-- | Strand from gen matrix.+strand' :: Integral a => a -> [[Gen a]] -> Strand a+strand' a = foldl srch (Strand [] a) where+ srch (Strand ss l) gs = case lkp l gs of+ Just (n,p) -> Strand (ss ++ [(l,p)]) n+ Nothing -> Strand (ss ++ [(l,O)]) l+ lkp _ [] = Nothing+ lkp l (Gen i p:gs) | l == i = Just (succ l,complement p)+ | l == succ i = Just (pred l,p)+ | otherwise = lkp l gs++-- | Extract all strands from a braid.+strands :: (Integral a, Braid b a) => b a -> [Strand a]+strands b = map (`strand'` toGens b) [minIndex b..succ $ maxIndex 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 { _lStrands :: [Strand a] }+ deriving (Eq,Show,Monoid,Functor)+makeLenses ''Loop++instance Foldable Loop where+ foldMap f = foldMap f . toListOf (lStrands.traverse.sWeaves.traverse._1)+instance ToWeaves (Loop a) a where+ toWeaves = toListOf (lStrands.traverse.sWeaves.traverse)+++++-- | Find loops in strands.+toLoops :: (Eq a,Show a) => [Strand a] -> [Loop a]+toLoops [] = []+toLoops sa = reverse $+ over (traverse.lStrands) (\s -> last s:init s) $+ recurL [] sa where+ shead = fst . head . _sWeaves+ findTail s = (==shead (head s)) . _sLast+ recurL ls [] = ls+ recurL ls (a:as) = recurS [a] as+ where recurS s ss =+ case filter (findTail s) ss of+ [] -> recurL (Loop s:ls) ss+ [t] -> recurS (t:s) (filter (not . findTail s) ss)+ ts -> error $ "More than one strand found with same tail: " ++ show ts+++-- | A la Reidemeister.+data Move b i = Move (b i) (b i)+ deriving (Eq,Show)+instance Field1 (Move b i) (Move b i) (b i) (b i) where+ _1 f (Move a b) = (`Move` b) <$> f a+instance Field2 (Move b i) (Move b i) (b i) (b i) where+ _2 f (Move a b) = Move a <$> f b++-- | Flip a move+inverse :: Move b i -> Move b i+inverse (Move a b) = Move b a++-- | Move "height" or strand count+moveH :: Braid a i => Move a i -> i+moveH (Move m1 m2) = max (strandCount m1) $ strandCount m2+-- | Move "width" or step count+moveW :: Braid a i => Move a i -> Int+moveW (Move m1 m2) = max (stepCount m1) $ stepCount m2++-- | Coordinate in braid.+data Loc a = Loc { _lx :: Int, _ly :: a } deriving (Eq,Show,Ord)+makeLenses ''Loc+instance Field1 (Loc a) (Loc a) Int Int where+ _1 f (Loc a b) = (`Loc` b) <$> f a+instance Field2 (Loc a) (Loc a) a a where+ _2 f (Loc a b) = Loc a <$> f b