Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 159 lines (123 sloc) 5.562 kB
c0e473a foo
alex authored
1 module Pattern where
2
3 import Control.Applicative
7323f69 @yaxu first commit
authored
4 import Data.Fixed
c0e473a foo
alex authored
5 import Data.List
5745356 foo
alex authored
6 import Data.Maybe
e9fb83a @yaxu more there
authored
7 import Data.Ratio
1a7e47c @yaxu getting there
authored
8 import Debug.Trace
7323f69 @yaxu first commit
authored
9
445a6ca @yaxu rejig
authored
10 type Range = (Rational, Rational)
de476a1 @yaxu Another rejig of pattern represetation
authored
11 type Event a = (Range, a)
0f40ddb @yaxu foo
authored
12
c25f802 @yaxu new representation more or less working
authored
13 data Pattern a = Sequence {arc :: Range -> [Event a]}
445a6ca @yaxu rejig
authored
14 | Signal {at :: Rational -> [a]}
0be7bab @yaxu hm
authored
15
445a6ca @yaxu rejig
authored
16 instance (Show a) => Show (Pattern a) where
c25f802 @yaxu new representation more or less working
authored
17 show p@(Sequence _) = show $ arc p (0,1)
445a6ca @yaxu rejig
authored
18 show p@(Signal _) = "~signal~"
10abb7b aha
alex authored
19
c25f802 @yaxu new representation more or less working
authored
20 silence = Sequence $ const []
1b628e1 @yaxu bugfix
authored
21
de476a1 @yaxu Another rejig of pattern represetation
authored
22 atom :: a -> Pattern a
c25f802 @yaxu new representation more or less working
authored
23 atom x = Sequence f
24 where f (s, d) = map
25 (\t -> ((fromIntegral t, 1), x))
26 [floor s .. (ceiling (s + d)) - 1]
0be7bab @yaxu hm
authored
27
de476a1 @yaxu Another rejig of pattern represetation
authored
28 instance Functor Pattern where
c25f802 @yaxu new representation more or less working
authored
29 fmap f (Sequence a) = Sequence $ fmap (fmap (mapSnd f)) a
30 fmap f (Signal a) = Signal $ fmap (fmap f) a
13b8d19 @yaxu things, and rational numbers
authored
31
de476a1 @yaxu Another rejig of pattern represetation
authored
32 instance Applicative Pattern where
33 pure x = Signal $ const [x]
c25f802 @yaxu new representation more or less working
authored
34 (Sequence fs) <*> (Sequence xs) =
35 Sequence $ \r -> concatMap
36 (\((o,d),x) -> map
37 (\(r', f) -> (r', f x))
38 (
39 filter
40 (\((o',d'),_) -> (o' >= o) && (o' < (o+d)))
41 (fs r)
42 )
43 )
44 (xs r)
de476a1 @yaxu Another rejig of pattern represetation
authored
45 (Signal fs) <*> (Signal xs) = Signal $ \t -> (fs t) <*> (xs t)
c25f802 @yaxu new representation more or less working
authored
46 (Signal fs) <*> px@(Sequence _) =
47 Signal $ \t -> concatMap (\(_, x) -> map (\f -> f x) (fs t)) (at' px t)
48 (Sequence fs) <*> (Signal xs) =
49 Sequence $ \r -> concatMap (\((o,d), f) ->
50 map (\x -> ((o,d), f x)) (xs o)) (fs r)
1b628e1 @yaxu bugfix
authored
51
c25f802 @yaxu new representation more or less working
authored
52 -- Strange hack - have to sample the discrete pattern to get the signal..
53 at' :: Pattern a -> Rational -> [Event a]
54 at' p@(Sequence _) t = filter (\((t', _), _) -> t >= t') $ arc p (t, 1%128)
55 at' p@(Signal _) t = undefined
445a6ca @yaxu rejig
authored
56
de476a1 @yaxu Another rejig of pattern represetation
authored
57 cat :: [Pattern a] -> Pattern a
b04cb75 @yaxu a bit more working
authored
58 cat ps = combine $ map (squash l) (zip [0..] ps)
445a6ca @yaxu rejig
authored
59 where l = length ps
60
61 squash :: Int -> (Int, Pattern a) -> Pattern a
c25f802 @yaxu new representation more or less working
authored
62 squash n (i, p) = Sequence $ \r -> concatMap doBit (bits r)
445a6ca @yaxu rejig
authored
63 where o' = (fromIntegral i)%(fromIntegral n)
64 d' = 1%(fromIntegral n)
65 subR :: Rational -> Range
66 cycle o = (fromIntegral $ floor o)
67 subR o = ((cycle o) + o', d')
68 doBit (o,d) = mapFsts scaleOut $ maybe [] ((arc p) . scaleIn) (subRange (o,d) (subR o))
69 scaleIn :: Range -> Range
70 scaleIn (o,d) = (o-o',d* (fromIntegral n))
71 scaleOut :: Range -> Range
b04cb75 @yaxu a bit more working
authored
72 scaleOut (o,d) = ((cycle o)+o'+ ((o-(cycle o))/(fromIntegral n)), d/ (fromIntegral n))
445a6ca @yaxu rejig
authored
73
74 subRange :: Range -> Range -> Maybe Range
75 subRange (o,d) (o',d') | d'' > 0 = Just (o'', d'')
76 | otherwise = Nothing
77 where o'' = max o (o')
78 d'' = (min (o+d) (o'+d')) - o''
79
80 -- chop range into ranges of unit cycles
81 bits :: Range -> [Range]
82 bits (_, 0) = []
83 bits (o, d) = (o,d'):bits (o+d',d-d')
84 where d' = min ((fromIntegral $ (floor o) + 1) - o) d
85
de476a1 @yaxu Another rejig of pattern represetation
authored
86 -- What about signals?
87 combine :: [Pattern a] -> Pattern a
c25f802 @yaxu new representation more or less working
authored
88 combine ps = Sequence $ \r -> concatMap (\p -> (arc p) r) ps
10abb7b aha
alex authored
89
de476a1 @yaxu Another rejig of pattern represetation
authored
90 patToOnsets :: Range -> Pattern a -> [Event a]
91 patToOnsets _ (Signal _) = [] --map (\x -> (t, x)) (a t)
c25f802 @yaxu new representation more or less working
authored
92 patToOnsets r (Sequence a) = a r
10abb7b aha
alex authored
93
de476a1 @yaxu Another rejig of pattern represetation
authored
94 filterEvents :: (Event a -> Bool) -> Pattern a -> Pattern a
c25f802 @yaxu new representation more or less working
authored
95 filterEvents f (Sequence a) = Sequence $ \r -> filter f $ a r
c0e473a foo
alex authored
96
de476a1 @yaxu Another rejig of pattern represetation
authored
97 -- Filter out events that start before range
98 filterOffsets :: Pattern a -> Pattern a
c25f802 @yaxu new representation more or less working
authored
99 filterOffsets (Sequence a) = Sequence $ \r -> filter ((>= (fst r)). fst . fst) $ a r
6ecfa70 @yaxu aha
authored
100
de476a1 @yaxu Another rejig of pattern represetation
authored
101 patToRelOnsets :: Range -> Pattern a -> [(Double, a)]
102 patToRelOnsets _ (Signal _) = []
103 patToRelOnsets (s, d) p = mapFsts (fromRational . (/ d) . (subtract s) . fst) $ patToOnsets (s, d) (filterOffsets p)
6ecfa70 @yaxu aha
authored
104
de476a1 @yaxu Another rejig of pattern represetation
authored
105 mapEvents :: (Event a -> Event a) -> Pattern a -> Pattern a
c25f802 @yaxu new representation more or less working
authored
106 mapEvents f (Sequence a) = Sequence $ \r -> map f (a r)
de476a1 @yaxu Another rejig of pattern represetation
authored
107 mapEvents f (Signal a) = Signal $ \t -> map (\x -> snd $ f ((t,0), x)) (a t)
10abb7b aha
alex authored
108
de476a1 @yaxu Another rejig of pattern represetation
authored
109 -- Maps time of events from an unmapped time range..
110 -- Generally not what you want..
6ecfa70 @yaxu aha
authored
111
de476a1 @yaxu Another rejig of pattern represetation
authored
112 mapEventRange :: (Rational -> Rational) -> Pattern a -> Pattern a
113 mapEventRange f p = mapEvents (mapFst f') p
114 where f' (s, d) = (f s, (f (s + d)) - (f s))
7323f69 @yaxu first commit
authored
115
13b8d19 @yaxu things, and rational numbers
authored
116 mapOnset :: (Rational -> Rational) -> Pattern a -> Pattern a
de476a1 @yaxu Another rejig of pattern represetation
authored
117 mapOnset f (Signal a) = Signal $ \t -> a (f t)
c25f802 @yaxu new representation more or less working
authored
118 mapOnset f (Sequence a) = Sequence $ \(s, d) -> a (f s, d)
7323f69 @yaxu first commit
authored
119
de476a1 @yaxu Another rejig of pattern represetation
authored
120 -- Function applied to both onset (start) and offset (start plus duration)
121 mapRange :: (Rational -> Rational) -> Pattern a -> Pattern a
c25f802 @yaxu new representation more or less working
authored
122 mapRange f p@(Sequence a) = Sequence $ \(s, d) -> a (f s, (f (s + d)) - (f s))
de476a1 @yaxu Another rejig of pattern represetation
authored
123 mapRange f p = mapOnset f p
1a550c1 hmm
alex authored
124
13b8d19 @yaxu things, and rational numbers
authored
125 (<~) :: Rational -> Pattern a -> Pattern a
de476a1 @yaxu Another rejig of pattern represetation
authored
126 (<~) t p = mapEventRange (+ t) $ mapRange (subtract t) p
7323f69 @yaxu first commit
authored
127
13b8d19 @yaxu things, and rational numbers
authored
128 (~>) :: Rational -> Pattern a -> Pattern a
de476a1 @yaxu Another rejig of pattern represetation
authored
129 (~>) t p = mapEventRange (subtract t) $ mapRange (+ t) p
7323f69 @yaxu first commit
authored
130
de476a1 @yaxu Another rejig of pattern represetation
authored
131 slow :: Rational -> Pattern a -> Pattern a
132 slow r p = mapEventRange (* r) $ mapRange (/ r) p
6ecfa70 @yaxu aha
authored
133
de476a1 @yaxu Another rejig of pattern represetation
authored
134 density :: Rational -> Pattern a -> Pattern a
135 density r p = mapEventRange (/ r) $ mapRange (* r) p
6ecfa70 @yaxu aha
authored
136
7323f69 @yaxu first commit
authored
137 every :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
138 every 0 _ p = p
866c506 @yaxu working
authored
139 every n f p = slow (fromIntegral n %1) $ cat $ (take (n-1) $ repeat p) ++ [f p]
7323f69 @yaxu first commit
authored
140
141 mapFst :: (a -> b) -> (a, c) -> (b, c)
142 mapFst f (x,y) = (f x,y)
143
591994f @yaxu foo
authored
144 mapFsts :: (a -> b) -> [(a, c)] -> [(b, c)]
145 mapFsts = map . mapFst
146
7323f69 @yaxu first commit
authored
147 mapSnd :: (a -> b) -> (c, a) -> (c, b)
148 mapSnd f (x,y) = (x,f y)
149
6ecfa70 @yaxu aha
authored
150 mapSnds :: (a -> b) -> [(c, a)] -> [(c, b)]
de476a1 @yaxu Another rejig of pattern represetation
authored
151 mapSnds = fmap . mapSnd
445a6ca @yaxu rejig
authored
152
153 sinewave :: Pattern Double
154 sinewave = Signal $ \t -> [(sin . (pi * 2 *)) (fromRational t)]
c25f802 @yaxu new representation more or less working
authored
155
156 sinewave1 :: Pattern Double
157 sinewave1 = fmap ((/ 2) . (+ 1)) sinewave
158
Something went wrong with that request. Please try again.