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

fiddles

master
alex 2019-11-01 20:19:43 +00:00
parent b27331c7f7
commit c7ae35b81a
4 changed files with 43 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
src/Common.hs
View File

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

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

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

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