{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GADTs #-}
-- | Diagrams for braids.
module Fadno.Braids.Graphics
    (
     DrawConf(..),
     renderBraid, BraidDrawF,
     renderStrand, StrandDrawF,
     colorStrands,colorLoops,
     gridStrand,renderBraids,
     randomBraid
    ) 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

import System.Random
import Numeric.Natural
import Control.Monad

-- | Configure braid/strand drawing.
data DrawConf = DrawConf {
      -- | step width (and height)
      DrawConf -> Int
stepWidth :: Int
      -- | strand line width
    , DrawConf -> Double
strandWidth :: Double
      -- | value > 0 and <= 1 specifying gap for "under" strands
    , DrawConf -> Double
crossGap :: Double
}
instance Default DrawConf where def :: DrawConf
def = Int -> Double -> Double -> DrawConf
DrawConf Int
40 Double
10 Double
0.2


-- | Draw rows and columns of braids with specified stepWidth and draw decorators.
renderBraids :: Braid b a => DrawConf -> [BraidDrawF a] -> FilePath -> [[b a]] -> IO ()
renderBraids :: forall (b :: * -> *) a.
Braid b a =>
DrawConf -> [BraidDrawF a] -> FilePath -> [[b a]] -> IO ()
renderBraids DrawConf
dc [BraidDrawF a]
drawFs FilePath
fpath [[b a]]
bs =
    FilePath -> Int -> Diagram B -> IO ()
renderRast FilePath
fpath
               (DrawConf -> Int
stepWidth DrawConf
dc Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
maxWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
maxCols)
               (Diagram B -> Diagram B
forall (v :: * -> *) n t.
(InSpace v n t, R2 v, Transformable t) =>
t -> t
reflectY (Diagram B -> Diagram B) -> Diagram B -> Diagram B
forall a b. (a -> b) -> a -> b
$ Colour Double -> QDiagram B V2 (N B) Any -> QDiagram B V2 (N B) Any
forall n b q.
(TypeableFloat n, Renderable (Path V2 n) b, Monoid' q) =>
Colour Double -> QDiagram b V2 n q -> QDiagram b V2 n q
bg Colour Double
forall a. (Ord a, Floating a) => Colour a
white (QDiagram B V2 (N B) Any -> QDiagram B V2 (N B) Any)
-> QDiagram B V2 (N B) Any -> QDiagram B V2 (N B) Any
forall a b. (a -> b) -> a -> b
$ N B -> QDiagram B V2 (N B) Any -> QDiagram B V2 (N B) Any
forall (v :: * -> *) n m b.
(Metric v, OrderedField n, Monoid' m) =>
n -> QDiagram b v n m -> QDiagram b v n m
frame Double
N B
0.2 (QDiagram B V2 (N B) Any -> QDiagram B V2 (N B) Any)
-> QDiagram B V2 (N B) Any -> QDiagram B V2 (N B) Any
forall a b. (a -> b) -> a -> b
$
                [QDiagram B V2 (N B) Any] -> QDiagram B V2 (N B) Any
forall n a.
(InSpace V2 n a, Floating n, Juxtaposable a, HasOrigin a,
 Monoid' a) =>
[a] -> a
vcat ([QDiagram B V2 (N B) Any] -> QDiagram B V2 (N B) Any)
-> [QDiagram B V2 (N B) Any] -> QDiagram B V2 (N B) Any
forall a b. (a -> b) -> a -> b
$ ([b a] -> QDiagram B V2 Double Any)
-> [[b a]] -> [QDiagram B V2 Double Any]
forall a b. (a -> b) -> [a] -> [b]
map ([QDiagram B V2 Double Any] -> QDiagram B V2 Double Any
forall n a.
(InSpace V2 n a, Floating n, Juxtaposable a, HasOrigin a,
 Monoid' a) =>
[a] -> a
hcat ([QDiagram B V2 Double Any] -> QDiagram B V2 Double Any)
-> ([b a] -> [QDiagram B V2 Double Any])
-> [b a]
-> QDiagram B V2 Double Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b a -> QDiagram B V2 Double Any)
-> [b a] -> [QDiagram B V2 Double Any]
forall a b. (a -> b) -> [a] -> [b]
map b a -> QDiagram B V2 Double Any
drawB) [[b a]]
bs)
    where
      maxCols :: Int
maxCols = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ ([b a] -> Int) -> [[b a]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [b a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[b a]]
bs
      maxWidth :: Int
maxWidth = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (b a -> Int) -> [b a] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b a -> Int
forall (br :: * -> *) a. Braid br a => br a -> Int
stepCount ([[b a]] -> [b a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[b a]]
bs)
      drawB :: b a -> QDiagram B V2 Double Any
drawB = Double -> QDiagram B V2 Double Any -> QDiagram B V2 Double Any
forall (v :: * -> *) n m b.
(Metric v, OrderedField n, Monoid' m) =>
n -> QDiagram b v n m -> QDiagram b v n m
frame Double
0.8 (QDiagram B V2 Double Any -> QDiagram B V2 Double Any)
-> (b a -> QDiagram B V2 Double Any)
-> b a
-> QDiagram B V2 Double Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DrawConf -> [BraidDrawF a] -> b a -> Diagram B
forall a (b :: * -> *).
(Integral a, Braid b a) =>
DrawConf -> [BraidDrawF a] -> b a -> Diagram B
drawBraid DrawConf
dc [BraidDrawF a]
drawFs

-- | Draw a braid with specified stepWidth and draw decorators.
renderBraid :: (Braid b a) => DrawConf -> [BraidDrawF a] -> FilePath -> b a -> IO ()
renderBraid :: forall (b :: * -> *) a.
Braid b a =>
DrawConf -> [BraidDrawF a] -> FilePath -> b a -> IO ()
renderBraid DrawConf
dc [BraidDrawF a]
drawFs FilePath
fpath b a
b =
    FilePath -> Int -> Diagram B -> IO ()
renderRast FilePath
fpath (DrawConf -> Int
stepWidth DrawConf
dc Int -> Int -> Int
forall a. Num a => a -> a -> a
* b a -> Int
forall (br :: * -> *) a. Braid br a => br a -> Int
stepCount b a
b) (Diagram B -> Diagram B
forall (v :: * -> *) n t.
(InSpace v n t, R2 v, Transformable t) =>
t -> t
reflectY (Diagram B -> Diagram B) -> Diagram B -> Diagram B
forall a b. (a -> b) -> a -> b
$ Colour Double -> QDiagram B V2 (N B) Any -> QDiagram B V2 (N B) Any
forall n b q.
(TypeableFloat n, Renderable (Path V2 n) b, Monoid' q) =>
Colour Double -> QDiagram b V2 n q -> QDiagram b V2 n q
bg Colour Double
forall a. (Ord a, Floating a) => Colour a
white (QDiagram B V2 (N B) Any -> QDiagram B V2 (N B) Any)
-> QDiagram B V2 (N B) Any -> QDiagram B V2 (N B) Any
forall a b. (a -> b) -> a -> b
$ N B -> Diagram B -> Diagram B
forall (v :: * -> *) n m b.
(Metric v, OrderedField n, Monoid' m) =>
n -> QDiagram b v n m -> QDiagram b v n m
frame Double
N B
0.4 (Diagram B -> Diagram B) -> Diagram B -> Diagram B
forall a b. (a -> b) -> a -> b
$ DrawConf -> [BraidDrawF a] -> b a -> Diagram B
forall a (b :: * -> *).
(Integral a, Braid b a) =>
DrawConf -> [BraidDrawF a] -> b a -> Diagram B
drawBraid DrawConf
dc [BraidDrawF a]
drawFs b a
b)

-- | Draw a strand with specified stepWidth, color, and draw decorators.
renderStrand :: Integral a => DrawConf -> [StrandDrawF a] -> FilePath -> Colour Double -> Strand a -> IO ()
renderStrand :: forall a.
Integral a =>
DrawConf
-> [StrandDrawF a]
-> FilePath
-> Colour Double
-> Strand a
-> IO ()
renderStrand DrawConf
dc [StrandDrawF a]
drawFs FilePath
fp Colour Double
color s :: Strand a
s@(Strand [Weave a]
ss a
_l) =
    FilePath -> Int -> Diagram B -> IO ()
renderRast FilePath
fp (DrawConf -> Int
stepWidth DrawConf
dc Int -> Int -> Int
forall a. Num a => a -> a -> a
* ([Weave a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Weave a]
ss Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
                   (Diagram B -> Diagram B
forall (v :: * -> *) n t.
(InSpace v n t, R2 v, Transformable t) =>
t -> t
reflectY (Diagram B -> Diagram B) -> Diagram B -> Diagram B
forall a b. (a -> b) -> a -> b
$ Colour Double -> QDiagram B V2 (N B) Any -> QDiagram B V2 (N B) Any
forall n b q.
(TypeableFloat n, Renderable (Path V2 n) b, Monoid' q) =>
Colour Double -> QDiagram b V2 n q -> QDiagram b V2 n q
bg Colour Double
forall a. (Ord a, Floating a) => Colour a
white (QDiagram B V2 (N B) Any -> QDiagram B V2 (N B) Any)
-> QDiagram B V2 (N B) Any -> QDiagram B V2 (N B) Any
forall a b. (a -> b) -> a -> b
$ N B -> QDiagram B V2 (N B) Any -> QDiagram B V2 (N B) Any
forall (v :: * -> *) n m b.
(Metric v, OrderedField n, Monoid' m) =>
n -> QDiagram b v n m -> QDiagram b v n m
frame Double
N B
0.4 (QDiagram B V2 (N B) Any -> QDiagram B V2 (N B) Any)
-> QDiagram B V2 (N B) Any -> QDiagram B V2 (N B) Any
forall a b. (a -> b) -> a -> b
$
                    [Strand a -> QDiagram B V2 (N B) Any -> QDiagram B V2 (N B) Any]
-> Strand a -> QDiagram B V2 (N B) Any -> QDiagram B V2 (N B) Any
forall b a. [b -> a -> a] -> b -> a -> a
runFs [StrandDrawF a]
[Strand a -> QDiagram B V2 (N B) Any -> QDiagram B V2 (N B) Any]
drawFs Strand a
s (QDiagram B V2 (N B) Any -> QDiagram B V2 (N B) Any)
-> QDiagram B V2 (N B) Any -> QDiagram B V2 (N B) Any
forall a b. (a -> b) -> a -> b
$ Double -> QDiagram B V2 (N B) Any -> QDiagram B V2 (N B) Any
forall a n. (N a ~ n, HasStyle a, Typeable n) => n -> a -> a
lwO Double
5 (QDiagram B V2 (N B) Any -> QDiagram B V2 (N B) Any)
-> QDiagram B V2 (N B) Any -> QDiagram B V2 (N B) Any
forall a b. (a -> b) -> a -> b
$ Colour Double -> Diagram B -> Diagram B
forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
Colour Double -> a -> a
lc Colour Double
color (Diagram B -> Diagram B) -> Diagram B -> Diagram B
forall a b. (a -> b) -> a -> b
$
                    DrawConf -> Strand a -> Diagram B
forall a. Integral a => DrawConf -> Strand a -> Diagram B
drawStrand DrawConf
dc Strand a
s)

renderRast :: FilePath -> Int -> Diagram B -> IO ()
renderRast :: FilePath -> Int -> Diagram B -> IO ()
renderRast FilePath
fpath Int
imgWidth = FilePath -> SizeSpec V2 Double -> QDiagram B V2 Double Any -> IO ()
forall n.
TypeableFloat n =>
FilePath -> SizeSpec V2 n -> QDiagram B V2 n Any -> IO ()
renderRasterific FilePath
fpath (Double -> SizeSpec V2 Double
forall n. Num n => n -> SizeSpec V2 n
mkWidth (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
imgWidth))

drawBraid :: (Integral a,Braid b a) => DrawConf -> [BraidDrawF a] -> b a -> Diagram B
drawBraid :: forall a (b :: * -> *).
(Integral a, Braid b a) =>
DrawConf -> [BraidDrawF a] -> b a -> Diagram B
drawBraid DrawConf
dc [BraidDrawF a]
fs b a
b = [Diagram B] -> Diagram B
forall a. Monoid a => [a] -> a
mconcat ([Diagram B] -> Diagram B) -> [Diagram B] -> Diagram B
forall a b. (a -> b) -> a -> b
$ [BraidDrawF a] -> BraidDrawF a
forall b a. [b -> a -> a] -> b -> a -> a
runFs [BraidDrawF a]
fs [Strand a]
ss ([Diagram B] -> [Diagram B]) -> [Diagram B] -> [Diagram B]
forall a b. (a -> b) -> a -> b
$ (Strand a -> QDiagram B V2 Double Any)
-> [Strand a] -> [QDiagram B V2 Double Any]
forall a b. (a -> b) -> [a] -> [b]
map (Double -> QDiagram B V2 Double Any -> QDiagram B V2 Double Any
forall a n. (N a ~ n, HasStyle a, Typeable n) => n -> a -> a
lwO (DrawConf -> Double
strandWidth DrawConf
dc) (QDiagram B V2 Double Any -> QDiagram B V2 Double Any)
-> (Strand a -> QDiagram B V2 Double Any)
-> Strand a
-> QDiagram B V2 Double Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DrawConf -> Strand a -> Diagram B
forall a. Integral a => DrawConf -> Strand a -> Diagram B
drawStrand DrawConf
dc) [Strand a]
ss
    where ss :: [Strand a]
ss = b a -> [Strand a]
forall a (b :: * -> *).
(Integral a, Braid b a) =>
b a -> [Strand a]
strands b a
b

drawStrand :: Integral a => DrawConf -> Strand a -> Diagram B
drawStrand :: forall a. Integral a => DrawConf -> Strand a -> Diagram B
drawStrand DrawConf
dc Strand a
s = ([P2 Double] -> Diagram B) -> [[P2 Double]] -> Diagram B
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (QDiagram B V2 Double Any -> QDiagram B V2 Double Any
cap (QDiagram B V2 Double Any -> QDiagram B V2 Double Any)
-> ([P2 Double] -> QDiagram B V2 Double Any)
-> [P2 Double]
-> QDiagram B V2 Double Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Point
   (V (QDiagram B V2 Double Any)) (N (QDiagram B V2 Double Any))]
-> QDiagram B V2 Double Any
[P2 Double] -> QDiagram B V2 Double Any
forall t. TrailLike t => [Point (V t) (N t)] -> t
fromVertices) ([[P2 Double]] -> Diagram B) -> [[P2 Double]] -> Diagram B
forall a b. (a -> b) -> a -> b
$ ([[P2 Double]] -> (Int, (a, Polarity, a)) -> [[P2 Double]])
-> [[P2 Double]] -> [(Int, (a, Polarity, a))] -> [[P2 Double]]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [[P2 Double]] -> (Int, (a, Polarity, a)) -> [[P2 Double]]
rs [[(a, Polarity, a) -> P2 Double
forall {a} {n} {b} {c}. (Integral a, Num n) => (a, b, c) -> P2 n
firstp ([(a, Polarity, a)] -> (a, Polarity, a)
forall a. HasCallStack => [a] -> a
head [(a, Polarity, a)]
ss)]] ([(Int, (a, Polarity, a))] -> [[P2 Double]])
-> [(Int, (a, Polarity, a))] -> [[P2 Double]]
forall a b. (a -> b) -> a -> b
$
                  [Int] -> [(a, Polarity, a)] -> [(Int, (a, Polarity, a))]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Int
0 :: Int)..] [(a, Polarity, a)]
ss
    where
      ss :: [(a, Polarity, a)]
ss = Strand a -> [(a, Polarity, a)]
forall a. Strand a -> Strand' a
toStrand' Strand a
s
      cap :: QDiagram B V2 Double Any -> QDiagram B V2 Double Any
cap = LineCap -> QDiagram B V2 Double Any -> QDiagram B V2 Double Any
forall a. HasStyle a => LineCap -> a -> a
lineCap LineCap
LineCapButt
      firstp :: (a, b, c) -> P2 n
firstp (a
y,b
_,c
_) = (n, n) -> P2 n
forall n. (n, n) -> P2 n
p2 (n
0,a -> n
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
y)
      margin :: Double
margin = (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- DrawConf -> Double
crossGap DrawConf
dc) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2
      rs :: [[P2 Double]] -> (Int, (a, Polarity, a)) -> [[P2 Double]]
rs [] (Int, (a, Polarity, a))
_ = FilePath -> [[P2 Double]]
forall a. HasCallStack => FilePath -> a
error FilePath
"no strands"
      rs ([P2 Double]
ps:[[P2 Double]]
pss) (Int
x,(a
y,Polarity
p,a
y')) | Polarity
p Polarity -> Polarity -> Bool
forall a. Eq a => a -> a -> Bool
== Polarity
U = [Double -> P2 Double
pt Double
1,Double -> P2 Double
pt (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
margin)][P2 Double] -> [[P2 Double]] -> [[P2 Double]]
forall a. a -> [a] -> [a]
:(Double -> P2 Double
pt Double
marginP2 Double -> [P2 Double] -> [P2 Double]
forall a. a -> [a] -> [a]
:[P2 Double]
ps)[P2 Double] -> [[P2 Double]] -> [[P2 Double]]
forall a. a -> [a] -> [a]
:[[P2 Double]]
pss
                            | Bool
otherwise       = (Double -> P2 Double
pt Double
1P2 Double -> [P2 Double] -> [P2 Double]
forall a. a -> [a] -> [a]
:[P2 Double]
ps)[P2 Double] -> [[P2 Double]] -> [[P2 Double]]
forall a. a -> [a] -> [a]
:[[P2 Double]]
pss
          where pt :: Double -> P2 Double
pt = Int -> a -> a -> Double -> P2 Double
forall a. Integral a => Int -> a -> a -> Double -> P2 Double
warpPt Int
x a
y a
y'

warpPt :: Integral a => Int -> a -> a -> Double -> P2 Double
warpPt :: forall a. Integral a => Int -> a -> a -> Double -> P2 Double
warpPt Int
x a
y a
y' Double
k = (Double, Double) -> P2 Double
forall n. (n, n) -> P2 n
p2 (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
k, a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
y Double -> Double -> Double
`delt` Double
k)
    where delt :: Double -> Double -> Double
delt | a
y a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
y' = (-)
               | a
y a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
y' = Double -> Double -> Double
forall a. Num a => a -> a -> a
(+)
               | Bool
otherwise = Double -> Double -> Double
forall a b. a -> b -> a
const


-- | Modify braid drawing, with strand data and diagrams.
type BraidDrawF a = [Strand a] -> [Diagram B] -> [Diagram B]
-- | Modify a single-strand drawing, with strand and diagram.
type StrandDrawF a = Strand a -> Diagram B -> Diagram B

-- | Color a braid's strands separately.
colorStrands :: BraidDrawF a
colorStrands :: forall a. BraidDrawF a
colorStrands [Strand a]
_ = (Colour Double
 -> QDiagram B V2 Double Any -> QDiagram B V2 Double Any)
-> [Colour Double]
-> [QDiagram B V2 Double Any]
-> [QDiagram B V2 Double Any]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Colour Double
-> QDiagram B V2 Double Any -> QDiagram B V2 Double Any
forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
Colour Double -> a -> a
lc [Colour Double]
forall a. (Ord a, Floating a) => [Colour a]
colors

-- | Color a braid's loops, such that looped strands have the same color.
colorLoops :: forall a . (Eq a,Show a) => BraidDrawF a
colorLoops :: forall a. (Eq a, Show a) => BraidDrawF a
colorLoops [Strand a]
ss = (Strand a -> QDiagram B V2 Double Any -> QDiagram B V2 Double Any)
-> [Strand a]
-> [QDiagram B V2 Double Any]
-> [QDiagram B V2 Double Any]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Strand a -> Diagram B -> Diagram B
Strand a -> QDiagram B V2 Double Any -> QDiagram B V2 Double Any
bs [Strand a]
ss
    where loops :: [Loop a]
loops = [Strand a] -> [Loop a]
forall a. (Eq a, Show a) => [Strand a] -> [Loop a]
toLoops [Strand a]
ss
          bs :: Strand a -> Diagram B -> Diagram B
          bs :: Strand a -> Diagram B -> Diagram B
bs Strand a
s = Colour Double
-> QDiagram B V2 Double Any -> QDiagram B V2 Double Any
forall n a.
(InSpace V2 n a, Typeable n, Floating n, HasStyle a) =>
Colour Double -> a -> a
lc ([Colour Double]
forall a. (Ord a, Floating a) => [Colour a]
colors [Colour Double] -> Int -> Colour Double
forall a. HasCallStack => [a] -> Int -> a
!! Int
seqidx)
              where seqidx :: Int
seqidx = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> Int
forall a. HasCallStack => FilePath -> a
error FilePath
"invalid braid, strand not in seqs") (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$
                             (Loop a -> Bool) -> [Loop a] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
L.findIndex (Strand a -> [Strand a] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Strand a
s ([Strand a] -> Bool) -> (Loop a -> [Strand a]) -> Loop a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loop a -> [Strand a]
forall a. Loop a -> [Strand a]
_lStrands) [Loop a]
loops


-- | Draw a grid behind a single strand.
gridStrand :: Integral a => StrandDrawF a
gridStrand :: forall a. Integral a => StrandDrawF a
gridStrand Strand a
s Diagram B
dia = ((Int -> QDiagram B V2 Double Any)
-> [Int] -> QDiagram B V2 Double Any
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Int -> Diagram B
Int -> QDiagram B V2 Double Any
yl [Int
0..a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
yd] QDiagram B V2 Double Any
-> QDiagram B V2 Double Any -> QDiagram B V2 Double Any
forall a. Semigroup a => a -> a -> a
<>
                                 (Int -> QDiagram B V2 Double Any)
-> [Int] -> QDiagram B V2 Double Any
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Int -> Diagram B
Int -> QDiagram B V2 Double Any
xl [Int
0..Int
xd])
                                 # lc lightgrey `beneath` dia
    where yl,xl :: Int -> Diagram B
          yl :: Int -> Diagram B
yl Int
i = [Point
   (V (QDiagram B V2 Double Any)) (N (QDiagram B V2 Double Any))]
-> QDiagram B V2 Double Any
forall t. TrailLike t => [Point (V t) (N t)] -> t
fromVertices [(Int, Int) -> P2 Double
forall a a1 n. (Integral a, Integral a1, Num n) => (a, a1) -> P2 n
dp2 (Int
0::Int,Int
i), (Int, Int) -> P2 Double
forall a a1 n. (Integral a, Integral a1, Num n) => (a, a1) -> P2 n
dp2 (Int
xd,Int
i)]
          xl :: Int -> Diagram B
xl Int
i = [Point
   (V (QDiagram B V2 Double Any)) (N (QDiagram B V2 Double Any))]
-> QDiagram B V2 Double Any
forall t. TrailLike t => [Point (V t) (N t)] -> t
fromVertices [(Int, Int) -> P2 Double
forall a a1 n. (Integral a, Integral a1, Num n) => (a, a1) -> P2 n
dp2 (Int
i,Int
0::Int), (Int, a) -> P2 Double
forall a a1 n. (Integral a, Integral a1, Num n) => (a, a1) -> P2 n
dp2 (Int
i,a
yd)]
          yd :: a
yd = Strand a -> a
forall a. Ord a => Strand a -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum Strand a
s a -> a -> a
forall a. Num a => a -> a -> a
- Strand a -> a
forall a. Ord a => Strand a -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum Strand a
s
          xd :: Int
xd = [Weave a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Strand a -> [Weave a]
forall a. Strand a -> [Weave a]
_sWeaves Strand a
s)



colors :: (Ord a, Floating a) => [Colour a]
colors :: forall a. (Ord a, Floating a) => [Colour a]
colors = [Colour a] -> [Colour a]
forall a. HasCallStack => [a] -> [a]
cycle [Colour a
forall a. (Ord a, Floating a) => Colour a
aqua, Colour a
forall a. (Ord a, Floating a) => Colour a
orange, Colour a
forall a. (Ord a, Floating a) => Colour a
deeppink, Colour a
forall a. (Ord a, Floating a) => Colour a
blueviolet, Colour a
forall a. (Ord a, Floating a) => Colour a
crimson, Colour a
forall a. (Ord a, Floating a) => Colour a
darkgreen, Colour a
forall a. (Ord a, Floating a) => Colour a
darkkhaki]

type Strand' a = [(a,Polarity,a)]

toStrand' :: Strand a -> Strand' a
toStrand' :: forall a. Strand a -> Strand' a
toStrand' (Strand [] a
_) = []
toStrand' (Strand [Weave a]
ss a
l) = (Weave a -> a -> (a, Polarity, a))
-> [Weave a] -> [a] -> [(a, Polarity, a)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(a
a,Polarity
p) a
n -> (a
a,Polarity
p,a
n)) [Weave a]
ss ([a] -> [a]
forall a. HasCallStack => [a] -> [a]
tail ((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])


runFs :: [b -> a -> a] -> b -> a -> a
runFs :: forall b a. [b -> a -> a] -> b -> a -> a
runFs [] b
_ = a -> a
forall a. a -> a
id
runFs [b -> a -> a]
fs' b
ss = ((a -> a) -> (a -> a) -> a -> a) -> [a -> a] -> a -> a
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) ([a -> a] -> a -> a)
-> ([b -> a -> a] -> [a -> a]) -> [b -> a -> a] -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((b -> a -> a) -> a -> a) -> [b -> a -> a] -> [a -> a]
forall a b. (a -> b) -> [a] -> [b]
map ((b -> a -> a) -> b -> a -> a
forall a b. (a -> b) -> a -> b
$ b
ss) ([b -> a -> a] -> a -> a) -> [b -> a -> a] -> a -> a
forall a b. (a -> b) -> a -> b
$ [b -> a -> a]
fs'


dp2 :: (Integral a, Integral a1, Num n) => (a, a1) -> P2 n
dp2 :: forall a a1 n. (Integral a, Integral a1, Num n) => (a, a1) -> P2 n
dp2 (a
a,a1
b) = (n, n) -> P2 n
forall n. (n, n) -> P2 n
p2 (a -> n
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
a, a1 -> n
forall a b. (Integral a, Num b) => a -> b
fromIntegral a1
b)



-- | Create a roughly square braid with specified strand count.
randomBraid :: Int -> IO (MultiGen Int)
randomBraid :: Int -> IO (MultiGen Int)
randomBraid Int
stepcount = [Step Int] -> MultiGen Int
forall a. [Step a] -> MultiGen a
MultiGen ([Step Int] -> MultiGen Int) -> IO [Step Int] -> IO (MultiGen Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int] -> (Int -> IO (Step Int)) -> IO [Step Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
1..Int
stepcount] (\Int
_ -> Int -> IO (Step Int)
randomStep Int
stepcount)

randomStep :: Int -> IO (Step Int)
randomStep :: Int -> IO (Step Int)
randomStep Int
stepcount = do
  let r :: a -> a -> m a
r a
a a
b = (a, a) -> m a
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (a
a,a
b)
      rp :: IO Polarity
rp = (\Bool
b -> if Bool
b then Polarity
O else Polarity
U) (Bool -> Polarity) -> IO Bool -> IO Polarity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Bool -> IO Bool
forall {a} {m :: * -> *}. (Random a, MonadIO m) => a -> a -> m a
r Bool
True Bool
False
  Gen Int
mk1 <- Int -> Polarity -> Gen Int
forall a. a -> Polarity -> Gen a
Gen (Int -> Polarity -> Gen Int) -> IO Int -> IO (Polarity -> Gen Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Int -> IO Int
forall {a} {m :: * -> *}. (Random a, MonadIO m) => a -> a -> m a
r Int
0 (Int
stepcount Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
10) IO (Polarity -> Gen Int) -> IO Polarity -> IO (Gen Int)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO Polarity
rp
  let mkSs :: Natural -> [Gen Natural] -> IO [Gen Natural]
      mkSs :: Natural -> [Gen Natural] -> IO [Gen Natural]
mkSs Natural
p [Gen Natural]
ss | Natural
p Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
< Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
stepcount = do
                    Gen Natural
s <- Natural -> Polarity -> Gen Natural
forall a. a -> Polarity -> Gen a
Gen (Natural -> Polarity -> Gen Natural)
-> IO Natural -> IO (Polarity -> Gen Natural)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Natural) -> IO Int -> IO Natural
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Int -> IO Int
forall {a} {m :: * -> *}. (Random a, MonadIO m) => a -> a -> m a
r (Int
0 :: Int) Int
steprange) IO (Polarity -> Gen Natural) -> IO Polarity -> IO (Gen Natural)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO Polarity
rp
                    Natural -> [Gen Natural] -> IO [Gen Natural]
mkSs (Natural
p Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Gen Natural -> Natural
forall a. Gen a -> a
_gPos Gen Natural
s Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
2) (Gen Natural
sGen Natural -> [Gen Natural] -> [Gen Natural]
forall a. a -> [a] -> [a]
:[Gen Natural]
ss)
                | Bool
otherwise = [Gen Natural] -> IO [Gen Natural]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Gen Natural]
ss
      steprange :: Int
steprange = if Int
heur Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Int
1 else Int
heur
      heur :: Int
heur = Int
stepcount Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
10
  [Gen Natural]
mss <- Natural -> [Gen Natural] -> IO [Gen Natural]
mkSs (Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Natural) -> Int -> Natural
forall a b. (a -> b) -> a -> b
$ Gen Int -> Int
forall a. Gen a -> a
_gPos Gen Int
mk1) []
  Step Int -> IO (Step Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Step Int -> IO (Step Int)) -> Step Int -> IO (Step Int)
forall a b. (a -> b) -> a -> b
$ Gen Int -> [Gen Natural] -> Step Int
forall a. Gen a -> [Gen Natural] -> Step a
Step Gen Int
mk1 [Gen Natural]
mss


_aBraid :: Artin Integer
_aBraid :: Artin Integer
_aBraid = [Gen Integer] -> Artin Integer
forall a. [Gen a] -> Artin a
Artin [Integer -> Polarity -> Gen Integer
forall a. a -> Polarity -> Gen a
Gen Integer
0 Polarity
O,Integer -> Polarity -> Gen Integer
forall a. a -> Polarity -> Gen a
Gen Integer
5 Polarity
U,Integer -> Polarity -> Gen Integer
forall a. a -> Polarity -> Gen a
Gen Integer
3 Polarity
O, Integer -> Polarity -> Gen Integer
forall a. a -> Polarity -> Gen a
Gen Integer
2 Polarity
U,Integer -> Polarity -> Gen Integer
forall a. a -> Polarity -> Gen a
Gen Integer
4 Polarity
O]
_aStrand :: Strand Integer
_aStrand :: Strand Integer
_aStrand = [Strand Integer] -> Strand Integer
forall a. HasCallStack => [a] -> a
head ([Strand Integer] -> Strand Integer)
-> [Strand Integer] -> Strand Integer
forall a b. (a -> b) -> a -> b
$ Artin Integer -> [Strand Integer]
forall a (b :: * -> *).
(Integral a, Braid b a) =>
b a -> [Strand a]
strands Artin Integer
_aBraid

_testpath :: FilePath
_testpath :: FilePath
_testpath = FilePath
"output/test.png"

_testRenderB :: IO ()
_testRenderB :: IO ()
_testRenderB = DrawConf
-> [BraidDrawF Integer] -> FilePath -> Artin Integer -> IO ()
forall (b :: * -> *) a.
Braid b a =>
DrawConf -> [BraidDrawF a] -> FilePath -> b a -> IO ()
renderBraid DrawConf
forall a. Default a => a
def [BraidDrawF Integer
forall a. BraidDrawF a
colorStrands] FilePath
_testpath Artin Integer
_aBraid
_testRenderS :: IO ()
_testRenderS :: IO ()
_testRenderS = DrawConf
-> [StrandDrawF Integer]
-> FilePath
-> Colour Double
-> Strand Integer
-> IO ()
forall a.
Integral a =>
DrawConf
-> [StrandDrawF a]
-> FilePath
-> Colour Double
-> Strand a
-> IO ()
renderStrand DrawConf
forall a. Default a => a
def [] FilePath
_testpath Colour Double
forall a. (Ord a, Floating a) => Colour a
crimson Strand Integer
_aStrand

_testRendRast :: Diagram B -> IO ()
_testRendRast :: Diagram B -> IO ()
_testRendRast = FilePath -> Int -> Diagram B -> IO ()
renderRast FilePath
_testpath Int
1000