module Fadno.Braids
(
module Fadno.Braids.Internal
,find,find',merge,mergeAt,mergeAt',clear,clearMerge
,reidemeister2,reidemeister3,findMoves,applyMove,moves,makeTree
,bandGen
,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
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]
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)
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
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 :: 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"
_drawLoops,_drawStrands :: (Show a, Integral a, Braid b a) => b a -> IO ()
_drawLoops = renderBraid def { stepWidth = 400 } [colorLoops] _testpath
_drawStrands = renderBraid def { stepWidth = 400 } [colorStrands] _testpath
reidemeister2 :: Integral a => Move Artin a
reidemeister2 = Move (Artin [Gen 0 O,Gen 0 U]) (Artin [])
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 def { stepWidth = 80 } [colorStrands] "output/reid3.png" $
map (\(Move a b) -> [a,b]) (reidemeister3 :: [Move Artin Int])
_drawMove :: (Integral i, Braid a i, Braid b i) => Move a i -> b i -> IO ()
_drawMove m b = renderBraids def { stepWidth = 80 } [colorStrands] "output/move.png"
[toMultiGen b:map toMultiGen [view _1 m, view _2 m],
map (\l -> applyMove m l b) (findMoves m b)]
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' :: (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)
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
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)
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
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
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
zipTail :: (a -> a -> c) -> [a] -> [c]
zipTail f = zipWith f <*> tail