Merge pull request #7 from tidalcycles/pihkal

Pihkal

src/Common.hs

@@ -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 :: Eq a => Pattern a -> [[Event a]]
-levelsWhole pat = arrangeEventsWhole $ sortOn' ((\Arc{..} -> stop - start) . part) (queryArc pat (Arc 0 1))
+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 :: Eq a => Pattern a -> [[Event a]]
-levels pat = arrangeEvents $ sortOn' ((\Arc{..} -> stop - start) . part) (queryArc pat (Arc 0 1))
+-- 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)
+    -> filter (\(Event _ _ (Arc start' stop') _) -> start' < stop && stop' > start)
-    $ groupByTime (segment' (queryArc p arc))
+    $ 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

src/CycleAnimation.hs

@@ -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))
 

src/Examples.hs

@@ -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 ()

src/Vis.hs

@@ -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 context whole Arc{..} value)
-      -> Event whole (Arc ((start - tick) / speed') ((stop - tick) / speed')) value
+      -> Event context whole (Arc ((start - tick) / speed') ((stop - tick) / speed')) value
     )
     $ queryArc (segmentator pat) (Arc tick (tick + speed'))
   where

src/VisCycle.hs

@@ -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)

src/VisGradient.hs

@@ -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 :: String -> String -> Pattern ColourD -> IO ()
-renderGradientSVG name pat = do
+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 :: String -> String -> Pattern ColourD -> IO ()
-renderGradientPDF name pat = do
+renderGradientPDF name label pat = do
     v C.withPDFSurface (name ++ ".pdf")
         (totalWidth, levelHeight * (fromIntegral $ length $ levels pat)) $ levels pat
     return ()

src/VisPart.hs

@@ -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 0 0.9 0.9 0.9 1
-            C.patternAddColorStopRGBA pat 1 0 0 0 0.5
+            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.TextExtents _ _ textW textH _ _) <- C.textExtents (stripQuotes $ show v)
-            C.moveTo (wx + 12) (y + textH + 16)
+            C.moveTo (wx + 12) (y + 24 + 16)
-            C.textPath (show v)
+            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 ()
+stripQuotes s = front $ back s
-renderPartSVG name pat = do
+  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 :: (Eq a, Show a) => String -> String -> Pattern a -> IO ()
-renderPartPDF name pat = do
+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 ()
 

tidal-vis.cabal

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