Skip to content

# yaxu/smooth

Newer
Older
100644 243 lines (188 sloc) 7.14 KB
 c0e473a foo alex authored Feb 29, 2012 1 module Pattern where 2 3 import Control.Applicative 7323f69 first commit yaxu authored Feb 29, 2012 4 import Data.Fixed c0e473a foo alex authored Feb 29, 2012 5 import Data.List 5745356 foo alex authored Mar 2, 2012 6 import Data.Maybe e9fb83a more there yaxu authored Mar 11, 2012 7 import Data.Ratio 7323f69 first commit yaxu authored Feb 29, 2012 8 6ecfa70 aha yaxu authored Mar 4, 2012 9 data Pattern a = Atom {event :: a} 13b8d19 things, and rational numbers yaxu authored Mar 11, 2012 10 | Cycle {patterns :: [Pattern a]} 11 | Signal {at :: Rational -> Pattern a} 12 | Silence 13 | Arc {pattern :: Pattern a, 14 onset :: Rational, 15 scale :: Rational, 16 reps :: Rational 17 } c0e473a foo alex authored Feb 29, 2012 18 10aa5f7 no comment alex authored Mar 5, 2012 19 joinPattern :: Pattern (Pattern a) -> Pattern a 20 joinPattern = mapAtom (\(Atom x) -> x) 0f40ddb foo yaxu authored Mar 1, 2012 21 10abb7b aha alex authored Mar 6, 2012 22 instance Applicative Pattern where 23 pure = Atom 10aa5f7 no comment alex authored Mar 5, 2012 24 9fef49c simplify yaxu authored Mar 6, 2012 25 Atom f <*> xs = f <\$> xs 26 fs <*> (Atom x) = (\f -> f x) <\$> fs 10aa5f7 no comment alex authored Mar 5, 2012 27 10abb7b aha alex authored Mar 6, 2012 28 (Cycle fs) <*> xs = Cycle \$ map (<*> xs) fs 29 fs <*> (Cycle xs) = Cycle \$ map (fs <*>) xs 30 31 fs@(Arc {onset = o}) <*> s@(Signal {}) = fs <*> (at s o) 32 fs@(Arc {}) <*> xs@(Arc {}) | isIn fs xs = fs {pattern = (pattern fs) <*> (pattern xs)} 13b8d19 things, and rational numbers yaxu authored Mar 11, 2012 33 | otherwise = Silence 10abb7b aha alex authored Mar 6, 2012 34 35 fs@(Signal {}) <*> xs = Signal \$ (<*> xs) . (at fs) 36 fs <*> xs@(Signal {}) = Signal \$ (fs <*>) . (at xs) 13b8d19 things, and rational numbers yaxu authored Mar 11, 2012 37 _ <*> Silence = Silence 38 Silence <*> _ = Silence 39 40 41 instance Monad Pattern where 42 return = pure 43 m >>= f = joinPattern (fmap f m) 10abb7b aha alex authored Mar 6, 2012 44 45 --where s n = mapAtom (\x -> mapAtom (\f -> Atom \$ (event f) (event x)) (at fs n)) xs 46 47 isIn :: Pattern a -> Pattern b -> Bool 13b8d19 things, and rational numbers yaxu authored Mar 11, 2012 48 isIn (Arc {onset = o1}) (Arc {onset = o2, reps = r2}) 49 = (o1 >= o2 && o1 < (o2 + r2)) 50 -- || (r2 == 0 && o1 == o2) e9fb83a more there yaxu authored Mar 11, 2012 51 isIn _ _ = False c0e473a foo alex authored Feb 29, 2012 52 53 instance Functor Pattern where 6ecfa70 aha yaxu authored Mar 4, 2012 54 fmap f p@(Atom {event = a}) = p {event = f a} 55 fmap f p@(Arc {pattern = p'}) = p {pattern = fmap f p'} 1a550c1 hmm alex authored Mar 1, 2012 56 fmap f p@(Cycle {patterns = ps}) = p {patterns = fmap (fmap f) ps} 10abb7b aha alex authored Mar 6, 2012 57 fmap f p@(Signal _) = p {at = (fmap f) . (at p)} 13b8d19 things, and rational numbers yaxu authored Mar 11, 2012 58 fmap _ Silence = Silence c0e473a foo alex authored Feb 29, 2012 59 1a550c1 hmm alex authored Mar 1, 2012 60 instance (Show a) => Show (Pattern a) where 13b8d19 things, and rational numbers yaxu authored Mar 11, 2012 61 show (Atom e) = show e 62 show (Arc p o d r) = concat ["[", show p, "@", show o, "x", show d, "]"] 63 show (Cycle ps) = "(" ++ (intercalate ", " (map show ps)) ++ ")" 10abb7b aha alex authored Mar 6, 2012 64 show (Signal s) = "*signal*" 13b8d19 things, and rational numbers yaxu authored Mar 11, 2012 65 show Silence = "~" 7323f69 first commit yaxu authored Feb 29, 2012 66 67 class Patternable p where 6ecfa70 aha yaxu authored Mar 4, 2012 68 toPattern :: p a -> Pattern a 7323f69 first commit yaxu authored Feb 29, 2012 69 70 instance Patternable [] where 6ecfa70 aha yaxu authored Mar 4, 2012 71 toPattern xs = Cycle ps 1a550c1 hmm alex authored Mar 1, 2012 72 where 6ecfa70 aha yaxu authored Mar 4, 2012 73 ps = map (\x -> Arc {pattern = Atom \$ xs !! x, e9fb83a more there yaxu authored Mar 11, 2012 74 onset = (fromIntegral x) % 13b8d19 things, and rational numbers yaxu authored Mar 11, 2012 75 (fromIntegral l), e9fb83a more there yaxu authored Mar 11, 2012 76 scale = 1 % (fromIntegral l), 13b8d19 things, and rational numbers yaxu authored Mar 11, 2012 77 reps = 1 1a550c1 hmm alex authored Mar 1, 2012 78 } 13b8d19 things, and rational numbers yaxu authored Mar 11, 2012 79 ) [0 .. l - 1] 80 l = length xs 7323f69 first commit yaxu authored Feb 29, 2012 81 6ecfa70 aha yaxu authored Mar 4, 2012 82 {-size :: Pattern a -> Double be8be0d foo yaxu authored Mar 2, 2012 83 size (Atom {}) = 1 591994f foo yaxu authored Mar 3, 2012 84 size (Cycle {extent = e}) = e be8be0d foo yaxu authored Mar 2, 2012 85 size (Combo []) = 0 86 size (Combo ps) = maximum \$ map size ps 6ecfa70 aha yaxu authored Mar 4, 2012 87 -} 88 89 90 silence :: Pattern a 13b8d19 things, and rational numbers yaxu authored Mar 11, 2012 91 silence = Silence be8be0d foo yaxu authored Mar 2, 2012 92 1a550c1 hmm alex authored Mar 1, 2012 93 mapAtom :: (Pattern a -> Pattern b) -> Pattern a -> Pattern b 6ecfa70 aha yaxu authored Mar 4, 2012 94 mapAtom f p@(Atom {}) = f p 95 mapAtom f p@(Arc {pattern = p'}) = p {pattern = mapAtom f p'} 1a550c1 hmm alex authored Mar 1, 2012 96 mapAtom f p@(Cycle {patterns = ps}) = p {patterns = fmap (mapAtom f) ps} 10abb7b aha alex authored Mar 6, 2012 97 mapAtom f p@(Signal _) = p {at = fmap (mapAtom f) (at p)} 13b8d19 things, and rational numbers yaxu authored Mar 11, 2012 98 mapAtom _ Silence = Silence 10abb7b aha alex authored Mar 6, 2012 99 100 filterP :: (Pattern a -> Bool) -> Pattern a -> Pattern a 101 filterP f p@(Atom {}) | f p = p 13b8d19 things, and rational numbers yaxu authored Mar 11, 2012 102 | otherwise = Silence 10abb7b aha alex authored Mar 6, 2012 103 filterP f p@(Cycle ps) | f p = p {patterns = map (filterP f) ps} 13b8d19 things, and rational numbers yaxu authored Mar 11, 2012 104 | otherwise = Silence 10abb7b aha alex authored Mar 6, 2012 105 filterP f p@(Arc {}) | f p = p {pattern = filterP f (pattern p)} 13b8d19 things, and rational numbers yaxu authored Mar 11, 2012 106 | otherwise = Silence 10abb7b aha alex authored Mar 6, 2012 107 filterP f p@(Signal {}) | f p = p {at = (filterP f) . (at p)} 13b8d19 things, and rational numbers yaxu authored Mar 11, 2012 108 filterP _ Silence = Silence c0e473a foo alex authored Feb 29, 2012 109 6ecfa70 aha yaxu authored Mar 4, 2012 110 mapArc :: (Pattern a -> Pattern a) -> Pattern a -> Pattern a 111 mapArc f p@(Atom {}) = p 112 mapArc f p@(Arc {pattern = p'}) = f \$ p {pattern = mapArc f p'} 113 mapArc f p@(Cycle {patterns = ps}) = p {patterns = fmap (mapArc f) ps} 10abb7b aha alex authored Mar 6, 2012 114 mapArc f p@(Signal _) = p {at = fmap (mapArc f) (at p)} 13b8d19 things, and rational numbers yaxu authored Mar 11, 2012 115 mapArc _ Silence = Silence 10abb7b aha alex authored Mar 6, 2012 116 6ecfa70 aha yaxu authored Mar 4, 2012 117 118 {- 1a550c1 hmm alex authored Mar 1, 2012 119 mapEvent :: (Event a -> Event b) -> Pattern a -> Pattern b 120 mapEvent f p = mapAtom (\p' -> p' {event = f (event p')}) p 6ecfa70 aha yaxu authored Mar 4, 2012 121 -} 7323f69 first commit yaxu authored Feb 29, 2012 122 13b8d19 things, and rational numbers yaxu authored Mar 11, 2012 123 mapOnset :: (Rational -> Rational) -> Pattern a -> Pattern a 6ecfa70 aha yaxu authored Mar 4, 2012 124 mapOnset f p = mapArc (\p' -> p' {onset = f \$ onset p'}) p 7323f69 first commit yaxu authored Feb 29, 2012 125 1a550c1 hmm alex authored Mar 1, 2012 126 rev :: Pattern a -> Pattern a 127 rev = mapOnset (1 -) 128 13b8d19 things, and rational numbers yaxu authored Mar 11, 2012 129 (<~) :: Rational -> Pattern a -> Pattern a 1a550c1 hmm alex authored Mar 1, 2012 130 d <~ p = mapOnset (\x -> mod' (x - d) 1) p 7323f69 first commit yaxu authored Feb 29, 2012 131 13b8d19 things, and rational numbers yaxu authored Mar 11, 2012 132 (~>) :: Rational -> Pattern a -> Pattern a 1a550c1 hmm alex authored Mar 1, 2012 133 d ~> p = (0-d) <~ p 7323f69 first commit yaxu authored Feb 29, 2012 134 6ecfa70 aha yaxu authored Mar 4, 2012 135 13b8d19 things, and rational numbers yaxu authored Mar 11, 2012 136 -- assumes equal scale.. 6ecfa70 aha yaxu authored Mar 4, 2012 137 138 cat :: [Pattern a] -> Pattern a 139 cat ps = Cycle \$ map a [0 .. (length ps) - 1] 140 where l = length ps e9fb83a more there yaxu authored Mar 11, 2012 141 s = 1 % (fromIntegral l) 6ecfa70 aha yaxu authored Mar 4, 2012 142 a n = Arc {pattern = ps !! n, 13b8d19 things, and rational numbers yaxu authored Mar 11, 2012 143 onset = s * (fromIntegral n), 144 scale = s, 145 reps = 1 6ecfa70 aha yaxu authored Mar 4, 2012 146 } 147 7323f69 first commit yaxu authored Feb 29, 2012 148 every :: Int -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a 149 every 0 _ p = p 150 every n f p = cat \$ (take (n-1) \$ repeat p) ++ [f p] 151 0f40ddb foo yaxu authored Mar 1, 2012 152 1a550c1 hmm alex authored Mar 1, 2012 153 --cat :: [Pattern a] -> Pattern a 154 --cat ps = Cycle (concatMap events ps') n 155 -- where shrunk = map (\p -> mapTime (* ((periodP p) / n)) p) ps 156 -- withOffsets = zip (0:(map (\p -> (periodP p) / n) shrunk)) shrunk 157 -- ps' = map (\(o, p) -> mapTime (+ o) p) \$ accumFst withOffsets 158 -- n = (sum \$ (map periodP) ps) c0e473a foo alex authored Feb 29, 2012 159 1a550c1 hmm alex authored Mar 1, 2012 160 combine :: [Pattern a] -> Pattern a 6ecfa70 aha yaxu authored Mar 4, 2012 161 combine = Cycle 7323f69 first commit yaxu authored Feb 29, 2012 162 1a550c1 hmm alex authored Mar 1, 2012 163 --accumOnsets :: [Event a] -> [Event a] 164 --accumOnsets = scanl1 (\a b -> mapOnset (+ (onset a)) b) c0e473a foo alex authored Feb 29, 2012 165 1a550c1 hmm alex authored Mar 1, 2012 166 --accumFst :: [(Double, a)] -> [(Double, a)] 167 --accumFst = scanl1 (\a b -> mapFst (+ (fst a)) b) 7323f69 first commit yaxu authored Feb 29, 2012 168 10abb7b aha alex authored Mar 6, 2012 169 sinewave :: Pattern Double 170 sinewave = Signal {at = f} 13b8d19 things, and rational numbers yaxu authored Mar 11, 2012 171 where f x = Arc {pattern = Atom \$ (sin . (pi * 2 *)) (fromRational x), 10abb7b aha alex authored Mar 6, 2012 172 onset = mod' x 1, 13b8d19 things, and rational numbers yaxu authored Mar 11, 2012 173 scale = 1, 174 reps = 1 10abb7b aha alex authored Mar 6, 2012 175 } 176 177 sinewave1 :: Pattern Double 178 sinewave1 = fmap ((/ 2) . (+ 1)) sinewave 179 180 {- be8be0d foo yaxu authored Mar 2, 2012 181 sample :: Int -> Signal a -> Pattern a 6ecfa70 aha yaxu authored Mar 4, 2012 182 sample n s = Cycle ps 10aa5f7 no comment alex authored Mar 5, 2012 183 where 6ecfa70 aha yaxu authored Mar 4, 2012 184 d = 1 / (fromIntegral n) 185 ps = map (\x -> 186 Arc { 187 pattern = Atom (s \$ (fromIntegral x) * d), 188 onset = (fromIntegral x) * d, 13b8d19 things, and rational numbers yaxu authored Mar 11, 2012 189 density = d 6ecfa70 aha yaxu authored Mar 4, 2012 190 } 191 ) 192 [0 .. (n - 1)] be8be0d foo yaxu authored Mar 2, 2012 193 10abb7b aha alex authored Mar 6, 2012 194 modulateOnset :: (a -> Double -> Double) -> Signal a -> Pattern b -> Pattern b 195 modulateOnset f s p = mapOnset (\x -> f (s x) x) p 7323f69 first commit yaxu authored Feb 29, 2012 196 10abb7b aha alex authored Mar 6, 2012 197 wobble :: Double -> Pattern a -> Pattern a 198 wobble d p = modulateOnset (+) (fmap (*d) sinewave) p 199 -} 7323f69 first commit yaxu authored Feb 29, 2012 200 mapFst :: (a -> b) -> (a, c) -> (b, c) 201 mapFst f (x,y) = (f x,y) 202 591994f foo yaxu authored Mar 3, 2012 203 mapFsts :: (a -> b) -> [(a, c)] -> [(b, c)] 204 mapFsts = map . mapFst 205 7323f69 first commit yaxu authored Feb 29, 2012 206 mapSnd :: (a -> b) -> (c, a) -> (c, b) 207 mapSnd f (x,y) = (x,f y) 208 6ecfa70 aha yaxu authored Mar 4, 2012 209 mapSnds :: (a -> b) -> [(c, a)] -> [(c, b)] 210 mapSnds = map . mapSnd 211 e9fb83a more there yaxu authored Mar 11, 2012 212 flatten' :: Pattern a -> [(Double, a)] 213 flatten' p = mapFsts (fromRational) (flatten p) 1a550c1 hmm alex authored Mar 1, 2012 214 13b8d19 things, and rational numbers yaxu authored Mar 11, 2012 215 flatten :: Pattern a -> [(Rational, a)] 6ecfa70 aha yaxu authored Mar 4, 2012 216 flatten (Atom e) = [(0, e)] 13b8d19 things, and rational numbers yaxu authored Mar 11, 2012 217 flatten Arc {pattern = p, onset = o, scale = s, reps = r} = 218 squash o s \$ flatten p 6ecfa70 aha yaxu authored Mar 4, 2012 219 flatten (Cycle ps) = concatMap flatten ps 13b8d19 things, and rational numbers yaxu authored Mar 11, 2012 220 flatten Silence = [] 221 222 flat :: (Rational, Rational) -> Pattern a -> [(Rational, a)] 223 flat (o, d) (Atom e) = [(0, e)] 224 flat (a, b) Arc {pattern = p, onset = o, scale = s, reps = r} 225 | isWithin = squash o s \$ flat (a', b') p 226 | otherwise = [] 227 where s' = b - a 228 a' = (o - a) / s' 229 b' = a' + (s / s') e9fb83a more there yaxu authored Mar 11, 2012 230 isWithin = (a' >= 0 && a' < 1) || (b' >= 0 && b' < 1) 13b8d19 things, and rational numbers yaxu authored Mar 11, 2012 231 232 flat (a, b) (Cycle ps) = concatMap (flat (a, b)) ps 233 flat _ Silence = [] 234 e9fb83a more there yaxu authored Mar 11, 2012 235 flat' :: (Rational, Rational) -> Pattern a -> [(Double, a)] 236 flat' r p = mapFsts (fromRational) (flat r p) 237 238 13b8d19 things, and rational numbers yaxu authored Mar 11, 2012 239 squash :: Rational -> Rational -> [(Rational, a)] -> [(Rational, a)] 240 squash o s es = mapFsts ((+ o) . (* s)) es 591994f foo yaxu authored Mar 3, 2012 241 5745356 foo alex authored Mar 2, 2012 242
Something went wrong with that request. Please try again.