Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 217 lines (169 sloc) 7.536 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
de476a1 @yaxu Another rejig of pattern represetation
authored
13 data Pattern a = Pattern {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
17 show p@(Pattern _) = show $ arc p (0,1)
18 show p@(Signal _) = "~signal~"
10abb7b aha
alex authored
19
de476a1 @yaxu Another rejig of pattern represetation
authored
20 silence = Pattern $ const $ []
1b628e1 @yaxu bugfix
authored
21
de476a1 @yaxu Another rejig of pattern represetation
authored
22 atom :: a -> Pattern a
23 atom x = Pattern $ \(s, d) -> map (\t -> ((fromIntegral t, fromIntegral t + 1), x)) [floor s .. (floor (s + d)) - 1]
0be7bab @yaxu hm
authored
24
de476a1 @yaxu Another rejig of pattern represetation
authored
25 --instance Functor Seq where
26 -- fmap f = Seq . mapSnds f . events
0be7bab @yaxu hm
authored
27
de476a1 @yaxu Another rejig of pattern represetation
authored
28 instance Functor Pattern where
29 fmap f (Pattern a) = Pattern $ \r -> fmap (mapSnd f) $ a r
30 fmap f (Signal a) = Signal $ \t -> fmap f (a t)
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]
34 (Pattern fs) <*> (Pattern xs) =
445a6ca @yaxu rejig
authored
35 Pattern $ \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 )
de476a1 @yaxu Another rejig of pattern represetation
authored
43 )
445a6ca @yaxu rejig
authored
44 (xs r)
de476a1 @yaxu Another rejig of pattern represetation
authored
45 (Signal fs) <*> (Signal xs) = Signal $ \t -> (fs t) <*> (xs t)
46 (Signal fs) <*> (Pattern xs) =
47 Signal $ \t -> concatMap (\(_, x) -> map (\f -> f x) (fs t)) (xs (t,0))
48 (Pattern fs) <*> (Signal xs) =
49 Pattern $ \r -> concatMap (\((o,d), f) -> map (\x -> ((o,d), f x)) (xs o)) (fs r)
1b628e1 @yaxu bugfix
authored
50
445a6ca @yaxu rejig
authored
51
1b628e1 @yaxu bugfix
authored
52
de476a1 @yaxu Another rejig of pattern represetation
authored
53 flatten :: (Rational, Rational) -> [Pattern a] -> [Event a]
54 flatten t ((Signal _):ps) = flatten t ps -- ignore signals
55 flatten (start, d) ps | d <= 0 = []
56 | otherwise =
57 es ++ (flatten (segStop, d-(segStop-start)) ps)
58 where l = length ps
59 loopStart = (floor start) % 1
60 segStart = fromIntegral (floor $ start * (fromIntegral l)) % (fromIntegral l)
61 segD = 1 % (fromIntegral l)
62 segStop = segStart + segD :: Rational
63 patTime t = loopStart + ((t - segStart) * (fromIntegral l))
64 patStart = patTime start
65 patStop = min (patTime (start + d)) (loopStart + 1)
66 patD = patStop - patStart
67 patN = mod (floor $ start * (fromIntegral l)) l
68 p = ps !! patN
69 es = mapFsts scale $ (arc p) (patStart, patD)
70 scale (sStart, sD) = (((sStart - loopStart) * segD) + segStart,
71 segD
72 )
73
445a6ca @yaxu rejig
authored
74 -- info = "\n" ++ concatMap (\(a, b) -> a ++ ": " ++ show b) thingsp
de476a1 @yaxu Another rejig of pattern represetation
authored
75 -- things = [("start", start), (" d", d), (" segStart", segStart), (" segD", segD)]
76
77 -- ignores signals - should return a signal if any are signals? via a fold..
78 cat :: [Pattern a] -> Pattern a
79 cat [] = silence
80 cat ps = Pattern $ \r -> flatten r ps
13b8d19 @yaxu things, and rational numbers
authored
81
445a6ca @yaxu rejig
authored
82 --catten :: [Pattern a] -> Pattern a
83 --catten ps = \r -> concatMap (squash r l) (zip [0..] ps)
84 -- where l = length ps
85 {-
86 squash :: Range -> Int -> (Int, Pattern a) -> [Event a]
87 squash r l (n, p) = concatMap ((arc p) . zoomIn) rs
88 where rs = map (\i -> (i, ranges r (fromIntegral l) i)) (take n [0 ..])
89 zoomIn (i, (o, d)) = (o*i,d*i)
90 zoomOut (i, (o, d)) = (o/i,d/i)
91 -}
92
93
94 catten :: [Pattern a] -> Pattern a
95 catten ps = combine $ map (squash l) (zip [0..] ps)
96 where l = length ps
97
98
99
100 squash :: Int -> (Int, Pattern a) -> Pattern a
101 squash n (i, p) = Pattern $ \r -> concatMap doBit (bits r)
102 where o' = (fromIntegral i)%(fromIntegral n)
103 d' = 1%(fromIntegral n)
104 subR :: Rational -> Range
105 cycle o = (fromIntegral $ floor o)
106 subR o = ((cycle o) + o', d')
107 doBit (o,d) = mapFsts scaleOut $ maybe [] ((arc p) . scaleIn) (subRange (o,d) (subR o))
108 scaleIn :: Range -> Range
109 scaleIn (o,d) = (o-o',d* (fromIntegral n))
110 scaleOut :: Range -> Range
111 scaleOut (o,d) = ((cycle o)+o'+ ((o-(cycle o))/(fromIntegral n)), d / (fromIntegral n))
112
113 subRange :: Range -> Range -> Maybe Range
114 subRange (o,d) (o',d') | d'' > 0 = Just (o'', d'')
115 | otherwise = Nothing
116 where o'' = max o (o')
117 d'' = (min (o+d) (o'+d')) - o''
118
119 --squash n (i, p) = Pattern $ \r -> maybe [] ((arc p) . (rangeIn subR))
120 -- where subR = (i'%n', 1%n')
121 -- i' = fromIntegral i
122 -- n' = fromIntegral n
123 --squashTime (o,d) = (o,d*)
124
125
126 {-
127 rangeIn :: Range -> Range -> Range
128 rangeIn (o,d) (o',d') = (o'', d'')
129 where o'' = (fromIntegral $ floor o) + ((o' - o) / d)
130 d'' = d' / d
131
132 subRange :: Range -> Range -> Maybe Range
133 subRange (o,d) (o',d') | d'' > 0 = Just (o'', d'')
134 | otherwise = Nothing
135 where o'' = max o (cycle+o')
136 d'' = (min (o+d) (cycle+o'+d')) - o''
137 cycle = fromIntegral $ floor o
138
139 -}
140
141 -- chop range into ranges of unit cycles
142 bits :: Range -> [Range]
143 bits (_, 0) = []
144 bits (o, d) = (o,d'):bits (o+d',d-d')
145 where d' = min ((fromIntegral $ (floor o) + 1) - o) d
146
de476a1 @yaxu Another rejig of pattern represetation
authored
147 -- What about signals?
148 combine :: [Pattern a] -> Pattern a
149 combine ps = Pattern $ \r -> concatMap (\p -> (arc p) r) ps
10abb7b aha
alex authored
150
de476a1 @yaxu Another rejig of pattern represetation
authored
151 patToOnsets :: Range -> Pattern a -> [Event a]
152 patToOnsets _ (Signal _) = [] --map (\x -> (t, x)) (a t)
153 patToOnsets r (Pattern a) = a r
10abb7b aha
alex authored
154
de476a1 @yaxu Another rejig of pattern represetation
authored
155 filterEvents :: (Event a -> Bool) -> Pattern a -> Pattern a
156 filterEvents f (Pattern a) = Pattern $ \r -> filter f $ a r
c0e473a foo
alex authored
157
de476a1 @yaxu Another rejig of pattern represetation
authored
158 -- Filter out events that start before range
159 filterOffsets :: Pattern a -> Pattern a
160 filterOffsets p@(Signal _) = p
161 filterOffsets p@(Pattern _) = filterEvents ((>= 0) . fst . fst) p
6ecfa70 @yaxu aha
authored
162
de476a1 @yaxu Another rejig of pattern represetation
authored
163 patToRelOnsets :: Range -> Pattern a -> [(Double, a)]
164 patToRelOnsets _ (Signal _) = []
165 patToRelOnsets (s, d) p = mapFsts (fromRational . (/ d) . (subtract s) . fst) $ patToOnsets (s, d) (filterOffsets p)
6ecfa70 @yaxu aha
authored
166
de476a1 @yaxu Another rejig of pattern represetation
authored
167 mapEvents :: (Event a -> Event a) -> Pattern a -> Pattern a
168 mapEvents f (Pattern a) = Pattern $ \r -> map f (a r)
169 mapEvents f (Signal a) = Signal $ \t -> map (\x -> snd $ f ((t,0), x)) (a t)
10abb7b aha
alex authored
170
de476a1 @yaxu Another rejig of pattern represetation
authored
171 -- Maps time of events from an unmapped time range..
172 -- Generally not what you want..
6ecfa70 @yaxu aha
authored
173
de476a1 @yaxu Another rejig of pattern represetation
authored
174 mapEventRange :: (Rational -> Rational) -> Pattern a -> Pattern a
175 mapEventRange f p = mapEvents (mapFst f') p
176 where f' (s, d) = (f s, (f (s + d)) - (f s))
7323f69 @yaxu first commit
authored
177
13b8d19 @yaxu things, and rational numbers
authored
178 mapOnset :: (Rational -> Rational) -> Pattern a -> Pattern a
de476a1 @yaxu Another rejig of pattern represetation
authored
179 mapOnset f (Signal a) = Signal $ \t -> a (f t)
180 mapOnset f (Pattern a) = Pattern $ \(s, d) -> a (f s, d)
7323f69 @yaxu first commit
authored
181
de476a1 @yaxu Another rejig of pattern represetation
authored
182 -- Function applied to both onset (start) and offset (start plus duration)
183 mapRange :: (Rational -> Rational) -> Pattern a -> Pattern a
184 mapRange f p@(Pattern a) = Pattern $ \(s, d) -> a (f s, (f (s + d)) - (f s))
185 mapRange f p = mapOnset f p
1a550c1 hmm
alex authored
186
13b8d19 @yaxu things, and rational numbers
authored
187 (<~) :: Rational -> Pattern a -> Pattern a
de476a1 @yaxu Another rejig of pattern represetation
authored
188 (<~) t p = mapEventRange (+ t) $ mapRange (subtract t) p
7323f69 @yaxu first commit
authored
189
13b8d19 @yaxu things, and rational numbers
authored
190 (~>) :: Rational -> Pattern a -> Pattern a
de476a1 @yaxu Another rejig of pattern represetation
authored
191 (~>) t p = mapEventRange (subtract t) $ mapRange (+ t) p
7323f69 @yaxu first commit
authored
192
de476a1 @yaxu Another rejig of pattern represetation
authored
193 slow :: Rational -> Pattern a -> Pattern a
194 slow r p = mapEventRange (* r) $ mapRange (/ r) p
6ecfa70 @yaxu aha
authored
195
de476a1 @yaxu Another rejig of pattern represetation
authored
196 density :: Rational -> Pattern a -> Pattern a
197 density r p = mapEventRange (/ r) $ mapRange (* r) p
6ecfa70 @yaxu aha
authored
198
7323f69 @yaxu first commit
authored
199 every :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
200 every 0 _ p = p
866c506 @yaxu working
authored
201 every n f p = slow (fromIntegral n %1) $ cat $ (take (n-1) $ repeat p) ++ [f p]
7323f69 @yaxu first commit
authored
202
203 mapFst :: (a -> b) -> (a, c) -> (b, c)
204 mapFst f (x,y) = (f x,y)
205
591994f @yaxu foo
authored
206 mapFsts :: (a -> b) -> [(a, c)] -> [(b, c)]
207 mapFsts = map . mapFst
208
7323f69 @yaxu first commit
authored
209 mapSnd :: (a -> b) -> (c, a) -> (c, b)
210 mapSnd f (x,y) = (x,f y)
211
6ecfa70 @yaxu aha
authored
212 mapSnds :: (a -> b) -> [(c, a)] -> [(c, b)]
de476a1 @yaxu Another rejig of pattern represetation
authored
213 mapSnds = fmap . mapSnd
445a6ca @yaxu rejig
authored
214
215 sinewave :: Pattern Double
216 sinewave = Signal $ \t -> [(sin . (pi * 2 *)) (fromRational t)]
Something went wrong with that request. Please try again.