Permalink
Browse files

easy density in parsing, plus cutoff/resonance and other things

  • Loading branch information...
1 parent a71aa87 commit c89c01e32f9e30d938c55e00ccbda04039b11aa6 @yaxu committed Oct 18, 2012
Showing with 122 additions and 69 deletions.
  1. +7 −1 Dirt.hs
  2. +36 −15 Parse.hs
  3. +77 −51 Pattern.hs
  4. +2 −2 Stream.hs
View
@@ -16,7 +16,10 @@ dirt = OscShape {path = "/play",
F "speed" (Just 1),
F "pan" (Just 0.5),
F "velocity" (Just 0),
- S "vowel" (Just "")
+ S "vowel" (Just ""),
+ F "cutoff" (Just 0),
+ F "resonance" (Just 0),
+ F "accellerate" (Just 0)
],
timestamp = True
}
@@ -38,6 +41,9 @@ speed = makeF dirt "speed"
pan = makeF dirt "pan"
velocity = makeF dirt "velocity"
vowel = makeS dirt "vowel"
+cutoff = makeF dirt "cutoff"
+resonance = makeF dirt "resonance"
+accellerate = makeF dirt "accellerate"
sample :: String -> Int -> String
sample name n = name ++ "/" ++ (show n)
View
@@ -7,6 +7,9 @@ import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Language ( haskellDef )
import Pattern
import Data.Ratio
+import Data.Colour
+import Data.Colour.Names
+import Data.Colour.SRGB
import GHC.Exts( IsString(..) )
@@ -25,10 +28,10 @@ instance Parseable Bool where
instance Parseable Int where
p = parseRhythm pInt
--- type ColourD = Colour Double
+type ColourD = Colour Double
--- instance Parseable ColourD where
--- p = parseRhythm pColour
+instance Parseable ColourD where
+ p = parseRhythm pColour
instance (Parseable a) => IsString (Pattern a) where
fromString = p
@@ -64,7 +67,6 @@ intOrFloat = do s <- sign
Left x -> Left (applySign s x)
)
-
r :: Parseable a => String -> Pattern a -> IO (Pattern a)
r s orig = do catch (return $ p s)
(\err -> do putStrLn (show err)
@@ -77,16 +79,14 @@ parseRhythm f input = either (const silence) id $ parse (pRhythm f') "" input
<|> do symbol "~" <?> "rest"
return silence
-
pRhythm :: Parser (Pattern a) -> GenParser Char () (Pattern a)
pRhythm f = do spaces
pSequence f
pSequence :: Parser (Pattern a) -> GenParser Char () (Pattern a)
-pSequence f = do --x <-pReps
+pSequence f = do d <- pDensity
ps <- many $ pPart f
- --let p = Arc (cat ps) 0 1 x
- return $ cat ps
+ return $ density d $ cat ps
pPart :: Parser (Pattern a) -> Parser (Pattern a)
pPart f = do part <- parens (pSequence f) <|> f <|> pPoly f
@@ -95,7 +95,9 @@ pPart f = do part <- parens (pSequence f) <|> f <|> pPoly f
pPoly :: Parser (Pattern a) -> Parser (Pattern a)
pPoly f = do ps <- brackets (pRhythm f `sepBy` symbol ",")
- return $ combine ps
+ spaces
+ m <- pMult
+ return $ density m $ combine ps
pString :: Parser (String)
pString = many1 (letter <|> oneOf "0123456789" <|> char '/') <?> "string"
@@ -120,16 +122,35 @@ pInt :: Parser (Pattern Int)
pInt = do i <- natural <?> "integer"
return $ atom (fromIntegral i)
+pColour :: Parser (Pattern ColourD)
+pColour = do name <- many1 letter <?> "colour name"
+ colour <- readColourName name <?> "known colour"
+ return $ atom colour
+
+pMult :: Parser (Rational)
+pMult = do char '*'
+ spaces
+ r <- pRatio
+ return r
+ <|>
+ do char '/'
+ spaces
+ r <- pRatio
+ return $ 1 / r
+ <|>
+ return 1
+
+
pRatio :: Parser (Rational)
pRatio = do n <- natural <?> "numerator"
- d <- do char '/'
+ d <- do oneOf "/%"
natural <?> "denominator"
<|>
- do return 1
+ return 1
return $ n % d
-pReps :: Parser (Rational)
-pReps = angles (pRatio <?> "ratio")
- <|>
- do return (1 % 1)
+pDensity :: Parser (Rational)
+pDensity = angles (pRatio <?> "ratio")
+ <|>
+ return (1 % 1)
View
@@ -6,22 +6,30 @@ import Data.List
import Data.Maybe
import Data.Ratio
import Debug.Trace
+import Data.Typeable
-type Range = (Rational, Rational)
-type Event a = (Range, a)
+type Time = Rational
+type Arc = (Time, Time)
+type Range = (Time, Maybe Time)
-data Pattern a = Sequence {arc :: (Rational, Maybe Rational) -> [Event a]}
- | Signal {at :: Rational -> [a]}
+type Event a = (Arc, a)
+
+data Pattern a = Sequence {range :: Range -> [Event a]}
+ | Signal {at :: Time -> [a]}
instance (Show a) => Show (Pattern a) where
- show p@(Sequence _) = show $ arc p (0, Just 1)
+ show p@(Sequence _) = show $ range p (0, Just 1)
show p@(Signal _) = "~signal~"
silence = Sequence $ const []
+silenceSig = Signal $ const []
+
+sam :: Time -> Time
+sam = fromIntegral . floor
atom :: a -> Pattern a
atom x = Sequence f
- where f (s, Nothing) = [((fromIntegral (floor s), 1), x)]
+ where f (s, Nothing) = [((sam s, 1), x)]
f (s, Just d) = map
(\t -> ((fromIntegral t, 1), x))
[floor s .. (ceiling (s + d)) - 1]
@@ -31,58 +39,52 @@ instance Functor Pattern where
fmap f (Signal a) = Signal $ fmap (fmap f) a
instance Applicative Pattern where
- pure x = Signal $ const [x]
+ pure = atom
(Sequence fs) <*> (Sequence xs) =
- Sequence $ \r -> concatMap
- (\((o,d),x) -> map
- (\(r', f) -> (r', f x))
- (
- filter
- (\((o',d'),_) -> (o' >= o) && (o' < (o+d)))
- (fs r)
- )
+ Sequence $ \r ->
+ concatMap
+ (\((o,d),x) -> map
+ (\(r', f) -> (r', f x))
+ (filter
+ (\((o',d'),_) -> (o' >= o) && (o' < (o+d)))
+ (fs r)
)
- (xs r)
+ )
+ (xs r)
(Signal fs) <*> (Signal xs) = Signal $ \t -> (fs t) <*> (xs t)
(Signal fs) <*> px@(Sequence _) =
- Signal $ \t -> concatMap (\(_, x) -> map (\f -> f x) (fs t)) (arc px (t,Nothing))
+ Signal $ \t -> concatMap (\(_, x) -> map (\f -> f x) (fs t)) (range px (t,Nothing))
(Sequence fs) <*> (Signal xs) =
Sequence $ \r -> concatMap (\((o,d), f) ->
map (\x -> ((o,d), f x)) (xs o)) (fs r)
-{-
-at' :: Pattern a -> Rational -> [Event a]
-at' p@(Sequence _) t = filter (\((t', _), _) -> t >= t') $ arc p (t, Nothing)
-at' p@(Signal _) t = undefined
--}
-
cat :: [Pattern a] -> Pattern a
cat ps = combine $ map (squash l) (zip [0..] ps)
where l = length ps
+listToPat :: [a] -> Pattern a
+listToPat = cat . map atom
+
tr x = trace (show x) x
squash :: Int -> (Int, Pattern a) -> Pattern a
squash n (i, p@(Sequence _)) = Sequence $ \r -> concatMap doBit (bits r)
where o' = (fromIntegral i)%(fromIntegral n)
d' = 1%(fromIntegral n)
- subR o = ((cyc o) + o', d')
- doBit (o,d) = mapFsts scaleOut $ maybe [] ((arc p) . scaleIn) (subRange (o,d) (subR o))
- -- scaleIn (o,d) = (o-o',d* (fromIntegral n))
- scaleIn (o, Just d) = ((cyc o)+((o-(cyc o)-o')*(fromIntegral n)), Just (d*(fromIntegral n)))
- scaleIn (o, Nothing) = ((cyc o)+((o-(cyc o)-o')*(fromIntegral n)), Nothing)
- scaleOut (o,d) = ((cyc o)+o'+((o-(cyc o))/(fromIntegral n)), d/(fromIntegral n))
+ subR o = ((sam o) + o', d')
+ doBit (o,d) = mapFsts scaleOut $ maybe [] ((range p) . scaleIn) (subRange (o,d) (subR o))
+ scaleIn (o, Just d) = ((sam o)+((o-(sam o)-o')*(fromIntegral n)), Just (d*(fromIntegral n)))
+ scaleIn (o, Nothing) = ((sam o)+((o-(sam o)-o')*(fromIntegral n)), Nothing)
+ scaleOut (o,d) = ((sam o)+o'+((o-(sam o))/(fromIntegral n)), d/(fromIntegral n))
squash n (i, p@(Signal _)) = Signal $ f
- where f t | (t - cyc t) >= t' && (t - cyc t) < (t'+d') = (at p) $ scaleIn t
+ where f t | (t - sam t) >= t' && (t - sam t) < (t'+d') = (at p) $ scaleIn t
| otherwise = []
t' = (fromIntegral i)%(fromIntegral n)
d' = 1%(fromIntegral n)
- scaleIn t = (cyc t)+((t-(cyc t)-t')*(fromIntegral n))
-
-cyc = fromIntegral . floor
+ scaleIn t = (sam t)+((t-(sam t)-t')*(fromIntegral n))
-subRange :: (Rational, Maybe Rational) -> Range -> Maybe (Rational, Maybe Rational)
+subRange :: Range -> Arc -> Maybe Range
subRange (o, Just d) (o',d') | d'' > 0 = Just (o'', Just d'')
| otherwise = Nothing
where o'' = max o (o')
@@ -91,7 +93,7 @@ subRange (o, Nothing) (o',d') | o >= o' && o < (o' + d') = Just (o, Nothing)
| otherwise = Nothing
-- chop range into ranges of unit cycles
-bits :: (Rational, Maybe Rational) -> [(Rational, Maybe Rational)]
+bits :: Range -> [Range]
bits r@(_, Nothing) = [r]
bits (_, Just 0) = []
bits (o, Just d) = (o, Just d'):bits (o+d',Just (d-d'))
@@ -106,7 +108,7 @@ combine ps = foldr f silence ps
foo (Sequence a) = a
foo _ = error "oops"
-patToOnsets :: (Rational, Maybe Rational) -> Pattern a -> [Event a]
+patToOnsets :: Range -> Pattern a -> [Event a]
patToOnsets _ (Signal _) = [] --map (\x -> (t, x)) (a t)
patToOnsets r (Sequence a) = a r
@@ -117,7 +119,7 @@ filterEvents f (Sequence a) = Sequence $ \r -> filter f $ a r
filterOffsets :: Pattern a -> Pattern a
filterOffsets (Sequence a) = Sequence $ \r -> filter ((>= (fst r)). fst . fst) $ a r
-patToRelOnsets :: (Rational, Maybe Rational) -> Pattern a -> [(Double, a)]
+patToRelOnsets :: Range -> Pattern a -> [(Double, a)]
patToRelOnsets _ (Signal _) = []
patToRelOnsets (s, Just d) p = mapFsts (fromRational . (/ d) . (subtract s) . fst) $ patToOnsets (s, Just d) (filterOffsets p)
patToRelOnsets (s, Nothing) _ = []
@@ -129,32 +131,38 @@ mapEvents f (Signal a) = Signal $ \t -> map (\x -> snd $ f ((t,0), x)) (a t)
-- Maps time of events from an unmapped time range..
-- Generally not what you want..
-mapEventRange :: (Rational -> Rational) -> Pattern a -> Pattern a
-mapEventRange f p = mapEvents (mapFst f') p
+mapEventArc :: (Time -> Time) -> Pattern a -> Pattern a
+mapEventArc f p = mapEvents (mapFst f') p
where f' (s, d) = (f s, (f (s + d)) - (f s))
-mapOnset :: (Rational -> Rational) -> Pattern a -> Pattern a
+mapEventOnset :: (Time -> Time) -> Pattern a -> Pattern a
+mapEventOnset f p = mapEvents (mapFst f') p
+ where f' (s, d) = (f s, d)
+
+mapOnset :: (Time -> Time) -> Pattern a -> Pattern a
mapOnset f (Signal a) = Signal $ \t -> a (f t)
mapOnset f (Sequence a) = Sequence $ \(s, d) -> a (f s, d)
-- Function applied to both onset (start) and offset (start plus duration)
-mapRange :: (Rational -> Rational) -> Pattern a -> Pattern a
-mapRange f p@(Sequence a) = Sequence a'
+mapTime :: (Time -> Time) -> Pattern a -> Pattern a
+mapTime f p@(Sequence a) = Sequence a'
where a' (s, Just d) = a (f s, Just $ (f (s + d)) - (f s))
a' (s, Nothing) = a (f s, Nothing)
-mapRange f p = mapOnset f p
+mapTime f p@(Signal a) = mapOnset f p
-(<~) :: Rational -> Pattern a -> Pattern a
-(<~) t p = mapEventRange (+ t) $ mapRange (subtract t) p
+(<~) :: Time -> Pattern a -> Pattern a
+(<~) t p = mapEventArc (+ t) $ mapTime (subtract t) p
-(~>) :: Rational -> Pattern a -> Pattern a
-(~>) t p = mapEventRange (subtract t) $ mapRange (+ t) p
+(~>) :: Time -> Pattern a -> Pattern a
+(~>) t p = mapEventArc (subtract t) $ mapTime (+ t) p
-slow :: Rational -> Pattern a -> Pattern a
-slow r p = mapEventRange (* r) $ mapRange (/ r) p
+slow :: Time -> Pattern a -> Pattern a
+slow 1 p = p
+slow r p = mapEventArc (* r) $ mapTime (/ r) p
-density :: Rational -> Pattern a -> Pattern a
-density r p = mapEventRange (/ r) $ mapRange (* r) p
+density :: Time -> Pattern a -> Pattern a
+density 1 p = p
+density r p = mapEventArc (/ r) $ mapTime (* r) p
every :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
every 0 _ p = p
@@ -178,3 +186,21 @@ sinewave = Signal $ \t -> [(sin . (pi * 2 *)) (fromRational t)]
sinewave1 :: Pattern Double
sinewave1 = fmap ((/ 2) . (+ 1)) sinewave
+triwave1 :: Pattern Double
+triwave1 = Signal $ \x -> [mod' (fromRational x) 1]
+
+triwave :: Pattern Double
+triwave = ((subtract 1) . (* 2)) <$> triwave1
+
+squarewave1 :: Pattern Double
+squarewave1 = Signal f
+ where f x = [fromIntegral $ floor $ (mod' (fromRational x) 1) * 2]
+
+squarewave :: Pattern Double
+squarewave = ((subtract 1) . (* 2)) <$> squarewave1
+
+{-rev :: Pattern a -> Pattern a
+rev = (mapEvents (mapFst swapSD)) . (mapEventArc revTime) . (mapOnset revTime)
+ where revTime x = sam x + (1 - (x - sam x))
+ swapSD (s,d) = ((s+d, 0-d))
+-}
View
@@ -77,7 +77,8 @@ toMessage s change ticks (o, m) =
usec = floor $ 1000000 * (logicalOnset - (fromIntegral sec))
oscdata = catMaybes $ mapMaybe (\x -> Map.lookup x m') (params s)
oscdata' = ((Int sec):(Int usec):oscdata)
- osc = Message (path s) oscdata'
+ osc | timestamp s = Message (path s) oscdata'
+ | otherwise = Bundle (UTCr logicalOnset) [Message (path s) oscdata]
return osc
@@ -117,7 +118,6 @@ onTick s shape patternM change ticks
catch (mapM_ (send s) messages) (\msg -> putStrLn $ "oops " ++ show msg)
return ()
-
make :: (a -> Datum) -> OscShape -> String -> Pattern a -> OscPattern
make toOsc s nm p = fmap (\x -> Map.singleton nParam (defaultV x)) p
where nParam = param s nm

0 comments on commit c89c01e

Please sign in to comment.