Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

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