Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 171 lines (127 sloc) 4.889 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
7323f69 @yaxu first commit
authored
7
6ecfa70 @yaxu aha
authored
8 data Pattern a = Atom {event :: a}
9 | Arc {pattern :: Pattern a,
10 onset :: Double,
11 duration :: Maybe Double
12 }
13 | Cycle {patterns :: [Pattern a]}
c0e473a foo
alex authored
14
15
0f40ddb @yaxu foo
authored
16
6ecfa70 @yaxu aha
authored
17 --data Pattern a = Atom a | Arc (Pattern a) (Double) (Maybe Double) | Cycle
c0e473a foo
alex authored
18
19 instance Functor Pattern where
6ecfa70 @yaxu aha
authored
20 fmap f p@(Atom {event = a}) = p {event = f a}
21 fmap f p@(Arc {pattern = p'}) = p {pattern = fmap f p'}
1a550c1 hmm
alex authored
22 fmap f p@(Cycle {patterns = ps}) = p {patterns = fmap (fmap f) ps}
c0e473a foo
alex authored
23
1a550c1 hmm
alex authored
24 instance (Show a) => Show (Pattern a) where
6ecfa70 @yaxu aha
authored
25 show (Atom e) = show e
26 show (Arc p o d) = concat [show p, "@", show o, "x", show d]
27 show (Cycle ps) = "(" ++ (intercalate ", " (map show ps)) ++ ")"
c0e473a foo
alex authored
28
1a550c1 hmm
alex authored
29 type Signal a = (Double -> a)
7323f69 @yaxu first commit
authored
30
1a550c1 hmm
alex authored
31 --instance Functor Signal where
32 -- fmap f s = fmap f s
7323f69 @yaxu first commit
authored
33
34 class Patternable p where
6ecfa70 @yaxu aha
authored
35 toPattern :: p a -> Pattern a
7323f69 @yaxu first commit
authored
36
37 instance Patternable [] where
6ecfa70 @yaxu aha
authored
38 toPattern xs = Cycle ps
1a550c1 hmm
alex authored
39 where
6ecfa70 @yaxu aha
authored
40 ps = map (\x -> Arc {pattern = Atom $ xs !! x,
41 onset = (fromIntegral x) /
1a550c1 hmm
alex authored
42 (fromIntegral $ length xs),
6ecfa70 @yaxu aha
authored
43 duration = Nothing
1a550c1 hmm
alex authored
44 }
6ecfa70 @yaxu aha
authored
45 ) [0 .. (length xs) - 1]
7323f69 @yaxu first commit
authored
46
6ecfa70 @yaxu aha
authored
47 {-size :: Pattern a -> Double
be8be0d @yaxu foo
authored
48 size (Atom {}) = 1
591994f @yaxu foo
authored
49 size (Cycle {extent = e}) = e
be8be0d @yaxu foo
authored
50 size (Combo []) = 0
51 size (Combo ps) = maximum $ map size ps
6ecfa70 @yaxu aha
authored
52 -}
53
54
55 silence :: Pattern a
56 silence = Cycle []
be8be0d @yaxu foo
authored
57
1a550c1 hmm
alex authored
58 mapAtom :: (Pattern a -> Pattern b) -> Pattern a -> Pattern b
6ecfa70 @yaxu aha
authored
59 mapAtom f p@(Atom {}) = f p
60 mapAtom f p@(Arc {pattern = p'}) = p {pattern = mapAtom f p'}
1a550c1 hmm
alex authored
61 mapAtom f p@(Cycle {patterns = ps}) = p {patterns = fmap (mapAtom f) ps}
c0e473a foo
alex authored
62
6ecfa70 @yaxu aha
authored
63 mapArc :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a
64 mapArc f p@(Atom {}) = p
65 mapArc f p@(Arc {pattern = p'}) = f $ p {pattern = mapArc f p'}
66 mapArc f p@(Cycle {patterns = ps}) = p {patterns = fmap (mapArc f) ps}
67
68 {-
1a550c1 hmm
alex authored
69 mapEvent :: (Event a -> Event b) -> Pattern a -> Pattern b
70 mapEvent f p = mapAtom (\p' -> p' {event = f (event p')}) p
6ecfa70 @yaxu aha
authored
71 -}
7323f69 @yaxu first commit
authored
72
1a550c1 hmm
alex authored
73 mapOnset :: (Double -> Double) -> Pattern a -> Pattern a
6ecfa70 @yaxu aha
authored
74 mapOnset f p = mapArc (\p' -> p' {onset = f $ onset p'}) p
7323f69 @yaxu first commit
authored
75
1a550c1 hmm
alex authored
76 rev :: Pattern a -> Pattern a
77 rev = mapOnset (1 -)
78
79 (<~) :: Double -> Pattern a -> Pattern a
80 d <~ p = mapOnset (\x -> mod' (x - d) 1) p
7323f69 @yaxu first commit
authored
81
1a550c1 hmm
alex authored
82 (~>) :: Double -> Pattern a -> Pattern a
83 d ~> p = (0-d) <~ p
7323f69 @yaxu first commit
authored
84
6ecfa70 @yaxu aha
authored
85
86 -- assumes equal duration..
87
88 cat :: [Pattern a] -> Pattern a
89 cat ps = Cycle $ map a [0 .. (length ps) - 1]
90 where l = length ps
91 d = 1 / (fromIntegral l)
92 a n = Arc {pattern = ps !! n,
93 onset = d * (fromIntegral n),
94 duration = Just d
95 }
96
7323f69 @yaxu first commit
authored
97 every :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
98 every 0 _ p = p
99 every n f p = cat $ (take (n-1) $ repeat p) ++ [f p]
100
0f40ddb @yaxu foo
authored
101
1a550c1 hmm
alex authored
102 --cat :: [Pattern a] -> Pattern a
103 --cat ps = Cycle (concatMap events ps') n
104 -- where shrunk = map (\p -> mapTime (* ((periodP p) / n)) p) ps
105 -- withOffsets = zip (0:(map (\p -> (periodP p) / n) shrunk)) shrunk
106 -- ps' = map (\(o, p) -> mapTime (+ o) p) $ accumFst withOffsets
107 -- n = (sum $ (map periodP) ps)
c0e473a foo
alex authored
108
1a550c1 hmm
alex authored
109 combine :: [Pattern a] -> Pattern a
6ecfa70 @yaxu aha
authored
110 combine = Cycle
7323f69 @yaxu first commit
authored
111
1a550c1 hmm
alex authored
112 --accumOnsets :: [Event a] -> [Event a]
113 --accumOnsets = scanl1 (\a b -> mapOnset (+ (onset a)) b)
c0e473a foo
alex authored
114
1a550c1 hmm
alex authored
115 --accumFst :: [(Double, a)] -> [(Double, a)]
116 --accumFst = scanl1 (\a b -> mapFst (+ (fst a)) b)
7323f69 @yaxu first commit
authored
117
be8be0d @yaxu foo
authored
118 sample :: Int -> Signal a -> Pattern a
6ecfa70 @yaxu aha
authored
119 sample n s = Cycle ps
120 where
121 d = 1 / (fromIntegral n)
122 ps = map (\x ->
123 Arc {
124 pattern = Atom (s $ (fromIntegral x) * d),
125 onset = (fromIntegral x) * d,
126 duration = Just d
127 }
128 )
129 [0 .. (n - 1)]
be8be0d @yaxu foo
authored
130
1a550c1 hmm
alex authored
131 sinewave :: Signal Double
132 sinewave = sin . (pi * 2 *)
7323f69 @yaxu first commit
authored
133
1a550c1 hmm
alex authored
134 sinewave1 :: Signal Double
135 sinewave1 = ((/ 2) . (+ 1)) . sinewave
7323f69 @yaxu first commit
authored
136
137 mapFst :: (a -> b) -> (a, c) -> (b, c)
138 mapFst f (x,y) = (f x,y)
139
591994f @yaxu foo
authored
140 mapFsts :: (a -> b) -> [(a, c)] -> [(b, c)]
141 mapFsts = map . mapFst
142
7323f69 @yaxu first commit
authored
143 mapSnd :: (a -> b) -> (c, a) -> (c, b)
144 mapSnd f (x,y) = (x,f y)
145
6ecfa70 @yaxu aha
authored
146 mapSnds :: (a -> b) -> [(c, a)] -> [(c, b)]
147 mapSnds = map . mapSnd
148
1a550c1 hmm
alex authored
149 modulateOnset :: (a -> Double -> Double) -> Signal a -> Pattern b -> Pattern b
150 modulateOnset f s p = mapOnset (\x -> f (s x) x) p
151
152 wobble :: Double -> Pattern a -> Pattern a
153 wobble d p = modulateOnset (+) (fmap (*d) sinewave) p
154
6ecfa70 @yaxu aha
authored
155 flatten :: Pattern a -> [(Double, a)]
156 flatten (Atom e) = [(0, e)]
157 flatten Arc {pattern = p, onset = o, duration = d} =
158 squash o d $ flatten p
159 flatten (Cycle ps) = concatMap flatten ps
591994f @yaxu foo
authored
160
6ecfa70 @yaxu aha
authored
161 squash :: Double -> Maybe Double -> [(Double, a)] -> [(Double, a)]
162 squash o d es = mapFsts ((+ o) . (* (fromMaybe 1 d))) es
5745356 foo
alex authored
163
6ecfa70 @yaxu aha
authored
164 {-
5745356 foo
alex authored
165 accumFst :: [(Double, a)] -> [(Double, a)]
166 accumFst = scanl1 (\a b -> mapFst (+ (fst a)) b)
6ecfa70 @yaxu aha
authored
167 modulate :: (a -> b -> c) -> Pattern a -> Signal b -> Pattern c
168 modulate f p s = fmap (
169 -}
1a550c1 hmm
alex authored
170
Something went wrong with that request. Please try again.