loooph
/
tidal-vis
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Merge pull request #7 from tidalcycles/pihkal 

Pihkal
master
Alex McLean 2020-09-13 23:53:32 +01:00 committed by GitHub
parent 503f0395ad 49f8d422a8
commit 56b97230f4
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
8 changed files with 57 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
src/Common.hs
View File

@ -2,6 +2,7 @@
module Common
( arrangeEvents
, arrangeEventsWhole
, beatNow
, dirtToColour
, fi
@ -44,11 +45,12 @@ addEventWhole e (level:ls)
arrangeEventsWhole :: [Event b] -> [[Event b]]
arrangeEventsWhole = foldr addEventWhole []
levelsWhole :: Pattern a -> [[Event a]]
levelsWhole pat = arrangeEventsWhole $ sortOn' ((\Arc{..} -> stop - start) . part) (queryArc pat (Arc 0 1))
levelsWhole :: Eq a => Pattern a -> [[Event a]]
levelsWhole pat = arrangeEventsWhole $ sortOn' ((\Arc{..} -> 0 - (stop - start)) . wholeOrPart) (defragParts $ queryArc pat (Arc 0 1))
-- levelsWhole pat = arrangeEventsWhole $ defragParts $ queryArc pat (Arc 0 1)
fits :: Event b -> [Event b] -> Bool
fits (Event _ part' _) events = not $ any (\Event{..} -> isJust $ subArc part' part) events
fits (Event _ _ part' _) events = not $ any (\Event{..} -> isJust $ subArc part' part) events
addEvent :: Event b -> [[Event b]] -> [[Event b]]
addEvent e [] = [[e]]
@ -59,8 +61,9 @@ addEvent e (level:ls)
arrangeEvents :: [Event b] -> [[Event b]]
arrangeEvents = foldr addEvent []
levels :: Pattern a -> [[Event a]]
levels pat = arrangeEvents $ sortOn' ((\Arc{..} -> stop - start) . part) (queryArc pat (Arc 0 1))
levels :: Eq a => Pattern a -> [[Event a]]
-- levels pat = arrangeEvents $ sortOn' ((\Arc{..} -> stop - start) . part) (defragParts $ queryArc pat (Arc 0 1))
levels pat = arrangeEvents $ reverse $ defragParts $ queryArc pat (Arc 0 1)
sortOn' :: Ord a => (b -> a) -> [b] -> [b]
sortOn' f = map snd . sortOn fst . map (\x -> let y = f x in y `seq` (y, x))
@ -79,8 +82,8 @@ stringToColour str = sRGB (r/256) (g/256) (b/256)
segmentator :: Pattern ColourD -> Pattern [ColourD]
segmentator p@Pattern{..} = Pattern $ \(State arc@Arc{..} _)
-> filter (\(Event _ (Arc start' stop') _) -> start' < stop && stop' > start)
$ groupByTime (segment' (queryArc p arc))
-> filter (\(Event _ _ (Arc start' stop') _) -> start' < stop && stop' > start)
$ groupByTime (segment' (defragParts $ queryArc p arc))
segment' :: [Event a] -> [Event a]
segment' es = foldr split es pts
@ -88,20 +91,20 @@ segment' es = foldr split es pts
split :: Time -> [Event a] -> [Event a]
split _ [] = []
split t (ev@(Event whole Arc{..} value):es)
split t (ev@(Event c whole Arc{..} value):es)
| t > start && t < stop =
Event whole (Arc start t) value : Event whole (Arc t stop) value : split t es
Event c whole (Arc start t) value : Event c whole (Arc t stop) value : split t es
| otherwise = ev:split t es
points :: [Event a] -> [Time]
points [] = []
points (Event _ Arc{..} _ : es) = start : stop : points es
points (Event _ _ Arc{..} _ : es) = start : stop : points es
groupByTime :: [Event a] -> [Event [a]]
groupByTime es = map merge $ groupBy ((==) `on` part) $ sortOn (stop . part) es
where
merge :: [EventF a b] -> EventF a [b]
merge evs@(Event{whole, part} : _) = Event whole part $ map (\Event{value} -> value) evs
merge evs@(Event{context, whole, part} : _) = Event context whole part $ map (\Event{value} -> value) evs
merge _ = error "groupByTime"
beatNow :: Tempo.Tempo -> IO Double

2
src/CycleAnimation.hs
View File

@ -196,7 +196,7 @@ drawPatR (x1,x2) p screen beat = mapM_ drawEvents $ event (pos beat) p
(width * fromRational (b - pos beat)) (width * fromRational (e - b)) 1
event :: Rational -> Pat.Pattern ColourD -> [((Rational, Rational), [ColourD])]
event position pat = map (\(Pat.Event _ Arc{..} events) ->
event position pat = map (\(Pat.Event _ _ Arc{..} events) ->
((max start position, min stop (position + 1)), events))
$ queryArc (segmentator pat) (Arc position (position + 1))

2
src/Examples.hs
View File

@ -27,7 +27,7 @@ matBundleRect = renderMatBundlePDF "./examples/" [foo, pip, pop, bar, buz]
-- | Make gradient rectangle pattern
gradientRect :: IO ()
gradientRect = renderGradientPDF "./examples/gradientRect" pip
gradientRect = renderGradientPDF "./examples/gradientRect" "" pip
-- | Make gradient rectangle pattern
matCycleWithBorders :: IO ()

6
src/Vis.hs
View File

@ -82,7 +82,7 @@ v sf fn (x,y) pat =
-- | Convert time and color to rendered type.
renderEvent :: Event [ColourD] -> C.Render ()
renderEvent (Event _ Arc{..} value) = do
renderEvent (Event _ _ Arc{..} value) = do
C.save
drawBlocks value 0
C.restore
@ -104,8 +104,8 @@ renderEvent (Event _ Arc{..} value) = do
events :: Pattern ColourD -> [Event [ColourD]]
events pat = map
( \(Event whole Arc{..} value)
-> Event whole (Arc ((start - tick) / speed') ((stop - tick) / speed')) value
( \(Event context whole Arc{..} value)
-> Event context whole (Arc ((start - tick) / speed') ((stop - tick) / speed')) value
)
$ queryArc (segmentator pat) (Arc tick (tick + speed'))
where

2
src/VisCycle.hs
View File

@ -52,7 +52,7 @@ renderLevel total (num, level) = do
C.restore
where
drawEvent :: Event ColourD -> C.Render ()
drawEvent (Event _ Arc{..} c) = do
drawEvent (Event _ _ Arc{..} c) = do
let (RGB r g b) = toSRGB c
let levelHeight = (1 / fi (total+1))/2
let h = levelHeight * fi (num + 1)

12
src/VisGradient.hs
View File

@ -17,7 +17,7 @@ totalWidth :: Double
totalWidth = 1700
ratio :: Double
ratio = 3/40
ratio = 2/40
levelHeight :: Double
levelHeight = totalWidth * ratio
@ -48,7 +48,7 @@ renderLevel _ (num, level) = do
mapM_ drawEvent $ level
C.restore
where
drawEvent e@(Event _ Arc{..} c) = do
drawEvent e@(Event _ _ Arc{..} c) = do
let (Arc sWhole eWhole) = wholeOrPart e
let (RGB r g b) = toSRGB c
let x = (fromRational start) * totalWidth
@ -82,14 +82,14 @@ renderLevel _ (num, level) = do
-- C.fill
-- C.stroke
renderGradientSVG :: String -> Pattern ColourD -> IO ()
renderGradientSVG name pat = do
renderGradientSVG :: String -> String -> Pattern ColourD -> IO ()
renderGradientSVG name label pat = do
v C.withSVGSurface (name ++ ".svg")
(totalWidth, levelHeight * (fromIntegral $ length $ levels pat)) $ levels pat
return ()
renderGradientPDF :: String -> Pattern ColourD -> IO ()
renderGradientPDF name pat = do
renderGradientPDF :: String -> String -> Pattern ColourD -> IO ()
renderGradientPDF name label pat = do
v C.withPDFSurface (name ++ ".pdf")
(totalWidth, levelHeight * (fromIntegral $ length $ levels pat)) $ levels pat
return ()

45
src/VisPart.hs
View File

@ -17,25 +17,35 @@ totalWidth :: Double
totalWidth = 1700
ratio :: Double
ratio = 3/40
ratio = 2/40
levelHeight :: Double
levelHeight = totalWidth * ratio
v :: Show a => (FilePath -> Double -> Double -> (C.Surface -> IO ()) -> IO ())
-> FilePath
-> (Double, Double)
-> [[Event a]]
-> String
-> IO ()
v sf fn (x,y) es = sf fn x y $ \surf ->
v sf fn (x,y) es label = sf fn x y $ \surf ->
C.renderWith surf $ do
C.setAntialias C.AntialiasBest
C.save
-- C.scale x (y / (fromIntegral $ length colorEvents))
C.setOperator C.OperatorOver
C.selectFontFace ("Inconsolata" :: String) C.FontSlantNormal C.FontWeightNormal
C.setFontSize 0.2
(C.TextExtents _ _ _ textH _ _) <- C.textExtents (label :: String)
C.moveTo 0 textH
C.textPath (label :: String)
C.setSourceRGB 0 0 0
C.fill
-- C.setSourceRGB 0 0 0
-- C.rectangle 0 0 1 1
--C.fill
C.setAntialias C.AntialiasBest
mapM_ (renderLevel (length es)) $ enumerate es
C.restore
@ -49,7 +59,7 @@ renderLevel _ (num, level) = do
mapM_ drawEvent $ level
C.restore
where
drawEvent e@(Event _ (Arc sPart ePart) v) = do
drawEvent e@(Event _ _ (Arc sPart ePart) v) = do
let (Arc sWhole eWhole) = wholeOrPart e
let (r, g, b) = (0,0,0)
let px = (fromRational sPart) * totalWidth
@ -64,8 +74,8 @@ renderLevel _ (num, level) = do
C.withLinearPattern wx 0 (ww + wx) 0 $ \pat -> do
C.save
C.patternAddColorStopRGBA pat 0 0.8 0.8 0.8 1
C.patternAddColorStopRGBA pat 1 0 0 0 0.5
C.patternAddColorStopRGBA pat 0 0.9 0.9 0.9 1
C.patternAddColorStopRGBA pat 1 0.4 0.4 0.4 0.5
C.patternSetFilter pat C.FilterFast
C.setSource pat
let leftGap = if px == wx then halfGap else 0
@ -111,9 +121,9 @@ renderLevel _ (num, level) = do
C.restore
C.selectFontFace ("Inconsolata" :: String) C.FontSlantNormal C.FontWeightNormal
C.setFontSize 35
(C.TextExtents _ _ textW textH _ _) <- C.textExtents (show v)
C.moveTo (wx + 12) (y + textH + 16)
C.textPath (show v)
(C.TextExtents _ _ textW textH _ _) <- C.textExtents (stripQuotes $ show v)
C.moveTo (wx + 12) (y + 24 + 16)
C.textPath (stripQuotes $ show v)
C.setSourceRGB 0 0 0
C.fill
-- C.save
@ -123,15 +133,20 @@ renderLevel _ (num, level) = do
-- C.fill
-- C.stroke
renderPartSVG :: Show a => String -> Pattern a -> IO ()
renderPartSVG name pat = do
stripQuotes s = front $ back s
where front ('"':xs) = xs
front xs = xs
back = reverse . front . reverse
renderPartSVG :: (Eq a, Show a) => String -> String -> Pattern a -> IO ()
renderPartSVG name label pat = do
v C.withSVGSurface (name ++ ".svg")
(totalWidth, levelHeight * (fromIntegral $ length $ levelsWhole pat)) $ levelsWhole pat
(totalWidth, levelHeight * (fromIntegral $ length $ levelsWhole pat)) (levelsWhole pat) label
return ()
renderPartPDF :: Show a => String -> Pattern a -> IO ()
renderPartPDF name pat = do
renderPartPDF :: (Eq a, Show a) => String -> String -> Pattern a -> IO ()
renderPartPDF name label pat = do
v C.withPDFSurface (name ++ ".pdf")
(totalWidth, levelHeight * (fromIntegral $ length $ levelsWhole pat)) $ levelsWhole pat
(totalWidth, levelHeight * (fromIntegral $ length $ levelsWhole pat)) (levelsWhole pat) label
return ()

2
tidal-vis.cabal
View File

@ -65,7 +65,7 @@ library
, SDL-ttf
, mtl
, network
, tidal >= 1.0.15 && < 1.5
, tidal >= 1.0.15 && < 1.7
, time
, unagi-chan