132 lines
4.9 KiB
Plaintext
132 lines
4.9 KiB
Plaintext
import Data.Graph
|
|
|
|
import Data.Graph.Inductive.Basic
|
|
|
|
import Data.Array
|
|
|
|
import Data.List
|
|
|
|
import qualified Data.Array as A
|
|
|
|
-- Tree, Forward, Back, Cross, Loop, No Edge
|
|
data EdgeType = T | F | B | X | L | NE deriving Show
|
|
--
|
|
tabulate :: Bounds -> [Vertex] -> Table Int
|
|
tabulate bnds vs = A.array bnds (zip vs [1..])
|
|
--
|
|
tabOrd :: Graph -> ([Tree Vertex] -> [Vertex]) -> Table Int
|
|
tabOrd g ord = tabulate (bounds g) $ ord $ dff g
|
|
--
|
|
tree :: Graph -> [Edge]
|
|
tree g = (concat (map flat ts))
|
|
where
|
|
ts = dff g
|
|
flat (Node v ts) = [ (v,w) | Node w us <- ts] ++ concat (map flat ts)
|
|
--
|
|
treeG :: Graph -> [Edge]
|
|
treeG = tree
|
|
--
|
|
back :: Graph -> Table Int -> [Edge]
|
|
back g post = filter f $ edges g
|
|
where f (v,w) = post ! v < post ! w
|
|
--
|
|
backG :: Graph -> [Edge]
|
|
backG g = back g $ tabOrd g postorderF
|
|
--
|
|
cross :: Graph -> Table Int -> Table Int -> [Edge]
|
|
cross g pre post = filter f $ edges g
|
|
where f (v,w) = post ! v > post ! w && pre ! v > pre ! w
|
|
--
|
|
crossG :: Graph -> [Edge]
|
|
crossG g = cross g (tabOrd g preorderF) (tabOrd g postorderF)
|
|
--
|
|
forward :: Graph -> Table Int -> [Edge]
|
|
forward g pre = (filter f $ edges g) \\ tree g
|
|
where f (v,w) = pre ! v < pre ! w
|
|
--
|
|
forwardG :: Graph -> [Edge]
|
|
forwardG g = forward g $ tabOrd g preorderF
|
|
--
|
|
-- basically only used for Edge -> Pattern Int as input for scale
|
|
pairfastcat :: (a, a) -> Pattern a
|
|
pairfastcat = (\(u,v) -> fastcat $ pure <$> [u,v])
|
|
--
|
|
nodeEdgePairs :: Graph -> [(Vertex,[Edge])]
|
|
nodeEdgePairs g = map (\u -> (u,[(u,v)| v <- g ! u])) $ preorderF $ dff g
|
|
--
|
|
edgeType :: Graph -> Edge -> EdgeType
|
|
edgeType g e@(x,y)
|
|
| p treeG = T
|
|
| p forwardG = F
|
|
| p backG = B
|
|
| p crossG = X
|
|
| x == y = L
|
|
| otherwise = NE
|
|
where p f = e `elem` (f g)
|
|
--
|
|
instrument :: Graph -> Edge -> [Char]
|
|
instrument g e = case edgeType g e of
|
|
T -> "clubkick"
|
|
F -> "superpwm"
|
|
B -> "casio"
|
|
X -> "amencutup"
|
|
L -> "sn"
|
|
NE -> " " -- let super collider deal with it
|
|
-- complete graph
|
|
k n = buildG (1,n) [(u,v)|u <- [1..n],v <- [1..n]]
|
|
-- path
|
|
p n = buildG (1,n) [(u,u+1)|u <- [1..n-1]]
|
|
-- reversed path TODO function to reverse all edges for arbitary graphs
|
|
p' n = buildG (1,n) [(u+1,u)|u <- [1..n-1]]
|
|
|
|
-- TODO Tiefe
|
|
-- TODO Wurzel betonen
|
|
-- TODO Blätter betonen?
|
|
|
|
g1 = buildG (0,6) [(1,5),(1,2),(1,3),(2,4),(3,6),(4,2),(4,3),(5,1),(5,2),(5,6),(6,0),(0,6)]
|
|
|
|
g2 = buildG (0,6) $ id <$> [(0,1),(1,2),(2,3),(3,4),(4,5),(5,6),(2,1)]
|
|
|
|
t1 = buildG (1,15) [(1,4),(1,12),(4,2),(4,6),(2,8),(2,3),(6,5),(6,7),(12,10),(12,14),(10,9),(10,11),(14,13),(14,15)]
|
|
--
|
|
nubbeKG = buildG (0,89) [(0,1),(0,2),(0,3),(0,4),(0,5),(0,6),(0,52),(0,53),(0,54),(1,68),(1,69),(1,70),(2,71),(2,72),(2,73),(2,74),(3,75),(3,76),(3,77),(3,78),(3,79),(3,80),(3,81),(3,82),(3,83),(3,84),(3,85),(3,86),(3,87),(3,88),(3,89),(4,7),(4,8),(4,9),(4,10),(4,11),(4,12),(4,13),(4,14),(4,15),(5,60),(5,61),(5,62),(5,63),(5,64),(5,65),(5,66),(5,67),(6,55),(6,56),(6,57),(6,58),(6,59),(7,16),(7,17),(7,18),(7,19),(8,48),(8,49),(8,50),(8,51),(9,44),(9,45),(9,46),(9,47),(10,40),(10,41),(10,42),(10,43),(11,36),(11,37),(11,38),(11,39),(12,32),(12,33),(12,34),(12,35),(13,28),(13,29),(13,30),(13,31),(14,24),(14,25),(14,26),(14,27),(15,20),(15,21),(15,22),(15,23)]
|
|
|
|
let edgePattern g e = (n $ pure $ toEnum $ (snd e) `mod` 31) # (s $ pure $ instrument g e) # pI "w" (pure $ snd e) # pS "edge_type" (pure $ show $ edgeType g e)
|
|
# gain 1
|
|
vertexPattern g v = (scale "ritusen" $ pure $ toEnum $ (v `mod` 31) - 10) # s "supersquare" # pI "vertex" (pure v)
|
|
# rate 0.1
|
|
# resonance 0.2
|
|
# end 0.2
|
|
# gain 0.8
|
|
patternize g = map (\(x,y) -> fastcat [vertexPattern g x, cat $ map (edgePattern g) y]) $ nodeEdgePairs g
|
|
gs = [ k 30
|
|
, p 2
|
|
]
|
|
in d1 $ id
|
|
$ qtrigger -- restart at the beginning of the preorder
|
|
$ fast 4.0 -- depends on maximum degree
|
|
$ ghost
|
|
$ (stack $ map cat $ map patternize gs)
|
|
# size "[0.8|0]"
|
|
# room "[0.7|0]"
|
|
# lpf "[1000|1500|2000]"
|
|
# pan (randcat [-0.5,-0.3,-0.1,0,0.1,0.3,0.5])
|
|
-- # delay "[0|0.2|0.3|0.4|0.5|0.6|0.7|0.8|0.9|1]"
|
|
-- # delayfb 0.3
|
|
|
|
hush
|
|
|
|
setcps (144/60/4)
|
|
|
|
-- testing stuff
|
|
|
|
d1 $ qtrigger $ fast 2 $ s "<numbers:1 clubkick:4 ~ rave:2 numbers:2 rave:4 ~ casio:2>" # end 0.2
|
|
|
|
d1 $ timeCat [(1,s "alphabet*4"), (4, fastcat [s "sn", s "bd", s "sn" , s "bd"])]
|
|
|
|
d1 $ fast 4 $ innerJoin $ fromList $ replicate 5 (cat [s "<alphabet ~ ~ ~>", cat [s "sn", s "jvbass", s "superpiano:0" , s "clubkick"]])
|
|
|
|
d1 $ fast 2 $ cat [s "<alphabet ~ ~ ~>", cat [s "sn", s "jvbass", s "superpiano:0" , s "clubkick"]]
|
|
|
|
let g = k 2 in (\(x,y) -> (x, (instrument g) <$> y)) <$> (nodeEdgePairs $ g)
|