fadno-braids 0.0.2 → 0.0.4
raw patch · 4 files changed
+114/−103 lines, 4 filesdep +data-defaultdep +random
Dependencies added: data-default, random
Files
- fadno-braids.cabal +4/−2
- src/Fadno/Braids.hs +5/−4
- src/Fadno/Braids/Graphics.hs +92/−84
- src/Fadno/Braids/Internal.hs +13/−13
fadno-braids.cabal view
@@ -1,6 +1,6 @@ name: fadno-braids category: Data, Math, Algebra-version: 0.0.2+version: 0.0.4 synopsis: Braid representations in Haskell description: Braids represented as Haskell types with support for generation and transformations. homepage: http://github.com/slpopejoy/@@ -23,10 +23,12 @@ -- other-extensions: build-depends: base >=4.8 && <4.9 , containers- , lens == 4.13.*+ , data-default >= 0.5.3 , diagrams == 1.3.* , diagrams-lib == 1.3.* , diagrams-rasterific == 1.3.*+ , lens == 4.13.*+ , random >= 1.1 , transformers-compat == 0.4.* hs-source-dirs: src default-language: Haskell2010
src/Fadno/Braids.hs view
@@ -71,6 +71,7 @@ import Fadno.Braids.Internal import Fadno.Braids.Graphics import Data.Tree+import Data.Default @@ -130,8 +131,8 @@ -- 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+_drawLoops = renderBraid def { stepWidth = 400 } [colorLoops] _testpath+_drawStrands = renderBraid def { stepWidth = 400 } [colorStrands] _testpath @@ -150,13 +151,13 @@ (\i -> if i == 0 then 1 else 0) (reverse gs) _drawReid3s :: IO ()-_drawReid3s = renderBraids 80 [colorStrands] "output/reid3.png" $+_drawReid3s = renderBraids def { stepWidth = 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"+_drawMove m b = renderBraids def { stepWidth = 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)]
src/Fadno/Braids/Graphics.hs view
@@ -1,12 +1,16 @@+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-} -- | Diagrams for braids. module Fadno.Braids.Graphics (+ DrawConf(..), renderBraid, BraidDrawF, renderStrand, StrandDrawF, colorStrands,colorLoops,- gridStrand,renderBraids+ gridStrand,renderBraids,+ randomBraid ) where import Fadno.Braids.Internal@@ -15,74 +19,64 @@ import qualified Data.List as L import Data.Maybe +import System.Random+import Numeric.Natural+import Control.Monad ------ Braid Drawing---+-- | Configure braid/strand drawing.+data DrawConf = DrawConf {+ -- | step width (and height)+ stepWidth :: Int+ -- | strand line width+ , strandWidth :: Double+ -- | value > 0 and <= 1 specifying gap for "under" strands+ , crossGap :: Double+}+instance Default DrawConf where def = DrawConf 40 10 0.2 -_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 =+renderBraids :: Braid b a => DrawConf -> [BraidDrawF a] -> FilePath -> [[b a]] -> IO ()+renderBraids dc drawFs fpath bs = renderRast fpath- (stepWidth * maxWidth * maxCols)+ (stepWidth dc * 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)+ drawB = frame 0.8 . drawBraid dc 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)+renderBraid :: (Braid b a) => DrawConf -> [BraidDrawF a] -> FilePath -> b a -> IO ()+renderBraid dc drawFs fpath b =+ renderRast fpath (stepWidth dc * stepCount b) (reflectY $ bg white $ frame 0.4 $ drawBraid dc drawFs b) -- | 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))+renderStrand :: Integral a => DrawConf -> [StrandDrawF a] -> FilePath -> Colour Double -> Strand a -> IO ()+renderStrand dc drawFs fp color s@(Strand ss _l) =+ renderRast fp (stepWidth dc * (length ss + 1)) (reflectY $ bg white $ frame 0.4 $- runFs drawFs $ lwO 5 $ lc color $- drawStrand s)- where runFs = foldl1 (.) . map ($ s)+ runFs drawFs s $ lwO 5 $ lc color $+ drawStrand dc 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])+drawBraid :: (Integral a,Braid b a) => DrawConf -> [BraidDrawF a] -> b a -> Diagram B+drawBraid dc fs b = mconcat $ runFs fs ss $ map (lwO (strandWidth dc) . drawStrand dc) ss+ where ss = strands b -drawStrand :: Integral a => Strand a -> Diagram B-drawStrand s = foldMap (cap . fromVertices) $ foldl rs [[firstp (head ss)]] $+drawStrand :: Integral a => DrawConf -> Strand a -> Diagram B+drawStrand dc 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+ margin = (1 - crossGap dc) / 2+ rs [] _ = error "no strands"+ rs (ps:pss) (x,(y,p,y')) | p == U = [pt 1,pt (1 - margin)]:(pt margin:ps):pss | otherwise = (pt 1:ps):pss where pt = warpPt x y y' @@ -93,20 +87,15 @@ | otherwise = const --- | A function to affect strand presentation in a braid.+-- | Modify braid drawing, with strand data and diagrams. type BraidDrawF a = [Strand a] -> [Diagram B] -> [Diagram B]--- | A function to affect strand presentation in a single-strand image.+-- | 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 _ = 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@@ -116,21 +105,7 @@ 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] <>@@ -142,27 +117,60 @@ yd = maximum s - minimum s xd = length (_sWeaves s) +++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])+++runFs :: [b -> a -> a] -> b -> a -> a+runFs [] _ = id+runFs fs' ss = foldl1 (.) . map ($ ss) $ fs'++ 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 --}+-- | Create a roughly square braid with specified strand count.+randomBraid :: Int -> IO (MultiGen Int)+randomBraid stepcount = MultiGen <$> forM [1..stepcount] (\_ -> randomStep stepcount)++randomStep :: Int -> IO (Step Int)+randomStep stepcount = do+ let r a b = randomRIO (a,b)+ rp = (\b -> if b then O else U) <$> r True False+ mk1 <- Gen <$> r 0 (stepcount `div` 10) <*> rp+ let mkSs :: Natural -> [Gen Natural] -> IO [Gen Natural]+ mkSs p ss | p < fromIntegral stepcount = do+ s <- Gen <$> (fromIntegral <$> r (0 :: Int) steprange) <*> rp+ mkSs (p + _gPos s + 2) (s:ss)+ | otherwise = return ss+ steprange = if heur == 0 then 1 else heur+ heur = stepcount `div` 10+ mss <- mkSs (fromIntegral $ _gPos mk1) []+ return $ Step mk1 mss+++_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 def [colorStrands] _testpath _aBraid+_testRenderS :: IO ()+_testRenderS = renderStrand def [] _testpath crimson _aStrand++_testRendRast :: Diagram B -> IO ()+_testRendRast = renderRast _testpath 1000
src/Fadno/Braids/Internal.hs view
@@ -193,28 +193,28 @@ -- | Braid representations.-class (Integral b, Monoid (a b)) => Braid (a :: * -> *) b where+class (Integral a, Monoid (br a)) => Braid br a where {-# MINIMAL toGens,minIndex,maxIndex,invert #-} -- | "Length", number of "steps"/columns/artin generators.- stepCount :: a b -> Int+ stepCount :: br a -> 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]]+ 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 :: a b -> b+ minIndex :: br a -> a -- | Maximum index (i) value. Note this means values of (i+1) obtain, per generators.- maxIndex :: a b -> b+ maxIndex :: br a -> a -- | Invert indices- invert :: a b -> a b+ invert :: br a -> br a -- | convert to single-gen- toArtin :: a b -> Artin b+ toArtin :: br a -> Artin a -- | convert to multi-gen- toMultiGen :: a b -> MultiGen b+ toMultiGen :: br a -> MultiGen a - strandCount a = (maxIndex a + 2) - minIndex a+ strandCount br = (maxIndex br + 2) - minIndex br stepCount = length . toGens -- inefficient @@ -225,7 +225,7 @@ -instance Integral a => Braid (Artin) a where+instance Integral a => Braid Artin a where toGens = map return . _aGens stepCount = length . _aGens minIndex (Artin []) = 0@@ -235,7 +235,7 @@ invert b = over (aGens.traverse.gPos) (maxIndex b -) b toArtin = id -instance Integral a => Braid (MultiGen) a where+instance Integral a => Braid MultiGen a where toGens = map stepToGens . _mSteps stepCount = length . _mSteps minIndex = minimum . map _gPos . concat . toGens