fiddles

src/Common.hs

@@ -2,6 +2,7 @@
 
 module Common
        ( arrangeEvents
+       , arrangeEventsWhole
        , beatNow
        , dirtToColour
        , fi
@@ -44,8 +45,9 @@ 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
@@ -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))
@@ -80,7 +83,7 @@ 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))
+    $ groupByTime (segment' (defragParts $ queryArc p arc))
 
 segment' :: [Event a] -> [Event a]
 segment' es = foldr split es pts

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/VisGradient.hs

@@ -17,7 +17,7 @@ totalWidth :: Double
 totalWidth = 1700
 
 ratio :: Double
-ratio = 3/40
+ratio = 2/40
 
 levelHeight :: Double
 levelHeight = totalWidth * ratio
@@ -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
 
@@ -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 ()