Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 119 lines (86 sloc) 3.632 kb
c0e473ad »
2012-02-29 foo
1 module Pattern where
2
3 import Control.Applicative
7323f69f »
2012-02-29 first commit
4 import Data.Fixed
c0e473ad »
2012-02-29 foo
5 import Data.List
7323f69f »
2012-02-29 first commit
6
1a550c16 »
2012-03-01 hmm
7 data Event a = Event {duration :: Maybe Double, value :: a}
c0e473ad »
2012-02-29 foo
8
0f40ddbf »
2012-03-01 foo
9 instance Functor Event where
10 fmap f e = e {value = (fmap f value e)}
c0e473ad »
2012-02-29 foo
11
0f40ddbf »
2012-03-01 foo
12 instance (Show a) => Show (Event a) where
13 show e = show $ value e
14
1a550c16 »
2012-03-01 hmm
15 data Pattern a = Atom {event :: Event a, onset :: Double}
16 | Cycle {patterns :: [Pattern a],
17 --density :: Double,
18 reps :: Double}
19 | Combo {patterns :: [Pattern a]}
c0e473ad »
2012-02-29 foo
20
21 instance Functor Pattern where
1a550c16 »
2012-03-01 hmm
22 fmap f p@(Atom {event = e}) = p {event = fmap f e}
23 fmap f p@(Cycle {patterns = ps}) = p {patterns = fmap (fmap f) ps}
24 fmap f (Combo ps) = Combo $ fmap (fmap f) ps
c0e473ad »
2012-02-29 foo
25
1a550c16 »
2012-03-01 hmm
26 instance (Show a) => Show (Pattern a) where
27 show (Atom e o) = show e ++ "@" ++ show o
28 show (Cycle ps r) =
29 (show r) ++ " x (" ++ (intercalate " " (map show ps)) ++ ")"
30 show (Combo ps) = intercalate ", " (map show ps)
c0e473ad »
2012-02-29 foo
31
1a550c16 »
2012-03-01 hmm
32 type Signal a = (Double -> a)
7323f69f »
2012-02-29 first commit
33
1a550c16 »
2012-03-01 hmm
34 --instance Functor Signal where
35 -- fmap f s = fmap f s
7323f69f »
2012-02-29 first commit
36
37 class Patternable p where
38 pattern :: p a -> Pattern a
39
40 instance Patternable [] where
1a550c16 »
2012-03-01 hmm
41 pattern xs = Cycle r 1
42 where
43 r = map (\x -> Atom {onset = (fromIntegral x) /
44 (fromIntegral $ length xs),
45 event = Event {
46 duration = Nothing,
47 value = xs !! x
48 }
49 }
0f40ddbf »
2012-03-01 foo
50 ) [0 .. (length xs) - 1]
7323f69f »
2012-02-29 first commit
51
1a550c16 »
2012-03-01 hmm
52 mapAtom :: (Pattern a -> Pattern b) -> Pattern a -> Pattern b
53 mapAtom f p@(Atom _ _) = f p
54 mapAtom f p@(Cycle {patterns = ps}) = p {patterns = fmap (mapAtom f) ps}
55 mapAtom f p@(Combo {patterns = ps}) = p {patterns = fmap (mapAtom f) ps}
c0e473ad »
2012-02-29 foo
56
1a550c16 »
2012-03-01 hmm
57 mapEvent :: (Event a -> Event b) -> Pattern a -> Pattern b
58 mapEvent f p = mapAtom (\p' -> p' {event = f (event p')}) p
7323f69f »
2012-02-29 first commit
59
1a550c16 »
2012-03-01 hmm
60 mapOnset :: (Double -> Double) -> Pattern a -> Pattern a
61 mapOnset f p = mapAtom (\p' -> p' {onset = f $ onset p'}) p
7323f69f »
2012-02-29 first commit
62
1a550c16 »
2012-03-01 hmm
63 rev :: Pattern a -> Pattern a
64 rev = mapOnset (1 -)
65
66 (<~) :: Double -> Pattern a -> Pattern a
67 d <~ p = mapOnset (\x -> mod' (x - d) 1) p
7323f69f »
2012-02-29 first commit
68
1a550c16 »
2012-03-01 hmm
69 (~>) :: Double -> Pattern a -> Pattern a
70 d ~> p = (0-d) <~ p
7323f69f »
2012-02-29 first commit
71
72 every :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
73 every 0 _ p = p
74 every n f p = cat $ (take (n-1) $ repeat p) ++ [f p]
75
76 cat :: [Pattern a] -> Pattern a
1a550c16 »
2012-03-01 hmm
77 cat ps = Cycle ps 1
0f40ddbf »
2012-03-01 foo
78
1a550c16 »
2012-03-01 hmm
79 --cat :: [Pattern a] -> Pattern a
80 --cat ps = Cycle (concatMap events ps') n
81 -- where shrunk = map (\p -> mapTime (* ((periodP p) / n)) p) ps
82 -- withOffsets = zip (0:(map (\p -> (periodP p) / n) shrunk)) shrunk
83 -- ps' = map (\(o, p) -> mapTime (+ o) p) $ accumFst withOffsets
84 -- n = (sum $ (map periodP) ps)
c0e473ad »
2012-02-29 foo
85
1a550c16 »
2012-03-01 hmm
86 combine :: [Pattern a] -> Pattern a
87 combine = Combo
7323f69f »
2012-02-29 first commit
88
1a550c16 »
2012-03-01 hmm
89 --accumOnsets :: [Event a] -> [Event a]
90 --accumOnsets = scanl1 (\a b -> mapOnset (+ (onset a)) b)
c0e473ad »
2012-02-29 foo
91
1a550c16 »
2012-03-01 hmm
92 --accumFst :: [(Double, a)] -> [(Double, a)]
93 --accumFst = scanl1 (\a b -> mapFst (+ (fst a)) b)
7323f69f »
2012-02-29 first commit
94
1a550c16 »
2012-03-01 hmm
95 sinewave :: Signal Double
96 sinewave = sin . (pi * 2 *)
7323f69f »
2012-02-29 first commit
97
1a550c16 »
2012-03-01 hmm
98 sinewave1 :: Signal Double
99 sinewave1 = ((/ 2) . (+ 1)) . sinewave
7323f69f »
2012-02-29 first commit
100
101 mapFst :: (a -> b) -> (a, c) -> (b, c)
102 mapFst f (x,y) = (f x,y)
103
104 mapSnd :: (a -> b) -> (c, a) -> (c, b)
105 mapSnd f (x,y) = (x,f y)
106
1a550c16 »
2012-03-01 hmm
107 modulateOnset :: (a -> Double -> Double) -> Signal a -> Pattern b -> Pattern b
108 modulateOnset f s p = mapOnset (\x -> f (s x) x) p
109
110 wobble :: Double -> Pattern a -> Pattern a
111 wobble d p = modulateOnset (+) (fmap (*d) sinewave) p
112
113 --flatten :: (Double, Double) -> Pattern a -> Pattern a
114 --flatten (startCycle, endCycle) p =
115
116
117
118 --modulate :: (a -> b -> c) -> Pattern a -> Signal b -> Pattern c
119 --modulate f p s = fmap (
Something went wrong with that request. Please try again.