new representation more or less working

yaxu · Sep 18, 2012 · c25f802 · c25f802
1 parent b04cb75
commit c25f802
Showing 1 changed file with 41 additions and 55 deletions.
diff --git a/Pattern.hs b/Pattern.hs
@@ -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
+