Permalink
Browse files

new representation more or less working

  • Loading branch information...
1 parent b04cb75 commit c25f8028a3e529bd1222b355d79cc26ba5fb0053 @yaxu committed Sep 18, 2012
Showing with 41 additions and 55 deletions.
  1. +41 −55 Pattern.hs
View
@@ -10,52 +10,56 @@ import Debug.Trace
type Range = (Rational, Rational)
type Event a = (Range, a)
-data Pattern a = Pattern {arc :: Range -> [Event a]}
+data Pattern a = Sequence {arc :: Range -> [Event a]}
| Signal {at :: Rational -> [a]}
instance (Show a) => Show (Pattern a) where
- show p@(Pattern _) = show $ arc p (0,1)
+ show p@(Sequence _) = show $ arc p (0,1)
show p@(Signal _) = "~signal~"
-silence = Pattern $ const $ []
+silence = Sequence $ const []
--- TODO adjust for overlaps..
atom :: a -> Pattern a
-atom x = Pattern $ \(s, d) -> map (\t -> ((fromIntegral t, fromIntegral 1), x)) [floor s .. (ceiling (s + d)) - 1]
-
---instance Functor Seq where
--- fmap f = Seq . mapSnds f . events
+atom x = Sequence f
+ where f (s, d) = map
+ (\t -> ((fromIntegral t, 1), x))
+ [floor s .. (ceiling (s + d)) - 1]
instance Functor Pattern where
- fmap f (Pattern a) = Pattern $ \r -> fmap (mapSnd f) $ a r
- fmap f (Signal a) = Signal $ \t -> fmap f (a t)
+ fmap f (Sequence a) = Sequence $ fmap (fmap (mapSnd f)) a
+ fmap f (Signal a) = Signal $ fmap (fmap f) a
instance Applicative Pattern where
pure x = Signal $ const [x]
- (Pattern fs) <*> (Pattern xs) =
- Pattern $ \r -> concatMap
- (\((o,d),x) -> map
- (\(r', f) -> (r', f x))
- (
- filter
- (\((o',d'),_) -> (o' >= o) && (o' < (o+d)))
- (fs r)
- )
- )
- (xs r)
+ (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)
+ )
+ )
+ (xs r)
(Signal fs) <*> (Signal xs) = Signal $ \t -> (fs t) <*> (xs t)
- (Signal fs) <*> (Pattern xs) =
- Signal $ \t -> concatMap (\(_, x) -> map (\f -> f x) (fs t)) (xs (t,0))
- (Pattern fs) <*> (Signal xs) =
- Pattern $ \r -> concatMap (\((o,d), f) -> map (\x -> ((o,d), f x)) (xs o)) (fs r)
+ (Signal fs) <*> px@(Sequence _) =
+ Signal $ \t -> concatMap (\(_, x) -> map (\f -> f x) (fs t)) (at' px t)
+ (Sequence fs) <*> (Signal xs) =
+ Sequence $ \r -> concatMap (\((o,d), f) ->
+ map (\x -> ((o,d), f x)) (xs o)) (fs r)
+-- Strange hack - have to sample the discrete pattern to get the signal..
+at' :: Pattern a -> Rational -> [Event a]
+at' p@(Sequence _) t = filter (\((t', _), _) -> t >= t') $ arc p (t, 1%128)
+at' p@(Signal _) t = undefined
cat :: [Pattern a] -> Pattern a
cat ps = combine $ map (squash l) (zip [0..] ps)
where l = length ps
squash :: Int -> (Int, Pattern a) -> Pattern a
-squash n (i, p) = Pattern $ \r -> concatMap doBit (bits r)
+squash n (i, p) = Sequence $ \r -> concatMap doBit (bits r)
where o' = (fromIntegral i)%(fromIntegral n)
d' = 1%(fromIntegral n)
subR :: Rational -> Range
@@ -73,28 +77,6 @@ subRange (o,d) (o',d') | d'' > 0 = Just (o'', d'')
where o'' = max o (o')
d'' = (min (o+d) (o'+d')) - o''
---squash n (i, p) = Pattern $ \r -> maybe [] ((arc p) . (rangeIn subR))
--- where subR = (i'%n', 1%n')
--- i' = fromIntegral i
--- n' = fromIntegral n
- --squashTime (o,d) = (o,d*)
-
-
-{-
-rangeIn :: Range -> Range -> Range
-rangeIn (o,d) (o',d') = (o'', d'')
- where o'' = (fromIntegral $ floor o) + ((o' - o) / d)
- d'' = d' / d
-
-subRange :: Range -> Range -> Maybe Range
-subRange (o,d) (o',d') | d'' > 0 = Just (o'', d'')
- | otherwise = Nothing
- where o'' = max o (cycle+o')
- d'' = (min (o+d) (cycle+o'+d')) - o''
- cycle = fromIntegral $ floor o
-
--}
-
-- chop range into ranges of unit cycles
bits :: Range -> [Range]
bits (_, 0) = []
@@ -103,25 +85,25 @@ bits (o, d) = (o,d'):bits (o+d',d-d')
-- What about signals?
combine :: [Pattern a] -> Pattern a
-combine ps = Pattern $ \r -> concatMap (\p -> (arc p) r) ps
+combine ps = Sequence $ \r -> concatMap (\p -> (arc p) r) ps
patToOnsets :: Range -> Pattern a -> [Event a]
patToOnsets _ (Signal _) = [] --map (\x -> (t, x)) (a t)
-patToOnsets r (Pattern a) = a r
+patToOnsets r (Sequence a) = a r
filterEvents :: (Event a -> Bool) -> Pattern a -> Pattern a
-filterEvents f (Pattern a) = Pattern $ \r -> filter f $ a r
+filterEvents f (Sequence a) = Sequence $ \r -> filter f $ a r
-- Filter out events that start before range
filterOffsets :: Pattern a -> Pattern a
-filterOffsets (Pattern a) = Pattern $ \r -> filter ((>= (fst r)). fst . fst) $ a r
+filterOffsets (Sequence a) = Sequence $ \r -> filter ((>= (fst r)). fst . fst) $ a r
patToRelOnsets :: Range -> Pattern a -> [(Double, a)]
patToRelOnsets _ (Signal _) = []
patToRelOnsets (s, d) p = mapFsts (fromRational . (/ d) . (subtract s) . fst) $ patToOnsets (s, d) (filterOffsets p)
mapEvents :: (Event a -> Event a) -> Pattern a -> Pattern a
-mapEvents f (Pattern a) = Pattern $ \r -> map f (a r)
+mapEvents f (Sequence a) = Sequence $ \r -> map f (a r)
mapEvents f (Signal a) = Signal $ \t -> map (\x -> snd $ f ((t,0), x)) (a t)
-- Maps time of events from an unmapped time range..
@@ -133,11 +115,11 @@ mapEventRange f p = mapEvents (mapFst f') p
mapOnset :: (Rational -> Rational) -> Pattern a -> Pattern a
mapOnset f (Signal a) = Signal $ \t -> a (f t)
-mapOnset f (Pattern a) = Pattern $ \(s, d) -> a (f s, d)
+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@(Pattern a) = Pattern $ \(s, d) -> a (f s, (f (s + d)) - (f s))
+mapRange f p@(Sequence a) = Sequence $ \(s, d) -> a (f s, (f (s + d)) - (f s))
mapRange f p = mapOnset f p
(<~) :: Rational -> Pattern a -> Pattern a
@@ -170,3 +152,7 @@ mapSnds = fmap . mapSnd
sinewave :: Pattern Double
sinewave = Signal $ \t -> [(sin . (pi * 2 *)) (fromRational t)]
+
+sinewave1 :: Pattern Double
+sinewave1 = fmap ((/ 2) . (+ 1)) sinewave
+

0 comments on commit c25f802

Please sign in to comment.