packages feed

boopadoop (empty) → 0.0.0.1

raw patch · 10 files changed

+527/−0 lines, 10 filesdep +WAVEdep +basedep +boopadoopsetup-changed

Dependencies added: WAVE, base, boopadoop, primes, semialign, split

Files

+ LICENSE view
@@ -0,0 +1,21 @@+MIT License
+
+Copyright (c) 2019 Lazersmoke
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.
+ README.md view
@@ -0,0 +1,4 @@+# boopadoop
+Mathematically sound sound synthesis.
+
+A music theory library for just intonation and other mathematically pure ideas.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ boopadoop.cabal view
@@ -0,0 +1,63 @@+cabal-version: 1.12
++-- This file has been generated from package.yaml by hpack version 0.31.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 425f991fc503fc954825df752ab44d8049b166438f4928aab27991d5435aea18++name:           boopadoop+version:        0.0.0.1+synopsis:       Mathematically sound sound synthesis+description:    Please see the README on GitHub at <https://github.com/Lazersmoke/boopadoop#readme>+category:       Music+homepage:       https://github.com/Lazersmoke/boopadoop#readme+bug-reports:    https://github.com/Lazersmoke/boopadoop/issues+author:         Sam Quinn+maintainer:     lazersmoke@gmail.com+copyright:      2019 Sam Quinn+license:        MIT+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md++source-repository head+  type: git+  location: https://github.com/Lazersmoke/boopadoop++library+  exposed-modules:+      Boopadoop+      Boopadoop.Diagram+      Boopadoop.Example+      Boopadoop.Interval+      Boopadoop.Rhythm+  other-modules:+      Paths_boopadoop+  hs-source-dirs:+      src+  build-depends:+      WAVE+    , base >=4.7 && <5+    , primes+    , semialign+    , split+  default-language: Haskell2010++test-suite boopadoop-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_boopadoop+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      WAVE+    , base >=4.7 && <5+    , boopadoop+    , primes+    , semialign+    , split+  default-language: Haskell2010
+ src/Boopadoop.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE FlexibleInstances #-}+-- | A music theory library for just intonation and other mathematically pure ideas.+module Boopadoop +  (module Boopadoop+  ,module Boopadoop.Diagram+  ,module Boopadoop.Rhythm+  ,module Boopadoop.Interval+  ) where++import Data.WAVE as WAVE+import Control.Applicative+import Boopadoop.Diagram+import Boopadoop.Rhythm+import Boopadoop.Interval+import Data.List++-- | A 'Waveform' is a function (of time) that we can later sample.+newtype Waveform t a = Waveform +  {sample :: t -> a -- ^ 'sample' the 'Waveform' at a specified time+  }++-- | A 'Double' valued wave with time also in terms of 'Double'.+-- This models a real-valued waveform which typically has values in @[-1,1]@ and+-- is typically supported on either the entire real line ('sinWave') or on a compact subset ('compactWave')+type DWave = Waveform Double Double++-- | Show a waveform by pretty printing some of the actual waveform in dot matrix form.+instance Show (Waveform Double Double) where+  show w = intercalate "\n" . transpose $ map sampleToString waveSamples+    where+      sampleToString k = replicate (quantLevel - k) '.' ++ "x" ++ replicate (quantLevel + k) '.'+      waveSamples = map (floor . (* realToFrac quantLevel) . sample w . (/sampleRate)) [0 .. 115]+      quantLevel = 15 :: Int+      sampleRate = 16000++-- | Build a 'Waveform' by sampling the given function.+sampleFrom :: (t -> a) -> Waveform t a+sampleFrom = Waveform++-- | Sample a 'Waveform' at specified time. @'sampleAt' = 'flip' 'sample'@+sampleAt :: t -> Waveform t a -> a+sampleAt = flip sample++-- | Pure sine wave of the given frequency+sinWave :: Double -> DWave+sinWave f = sampleFrom $ \t -> sin (2 * pi * f * t)++-- | @'compactWave' (l,h)@ is a wave which is @1@ on @[l,h)@ and @0@ elsewhere+compactWave :: (Ord t,Num t) => (t,t) -> Waveform t Bool+compactWave (low,high) = sampleFrom $ \t -> t >= low && t < high++-- | Modulate the muting or non-muting of another wave with a @'Bool'@ value wave, such as @'compactWave'@.+modulateMuting :: Num a => Waveform t Bool -> Waveform t a -> Waveform t a+modulateMuting = modulate (\b s -> if b then s else 0)++-- | Modulate one wave with another according to the given function pointwise.+-- This means you can't implement 'phaseModulate' using only this combinator because phase modulation+-- requires information about the target wave at times other than the current time.+modulate :: (a -> b -> c) -> Waveform t a -> Waveform t b -> Waveform t c+modulate f a b = sampleFrom $ \t -> f (sample a t) (sample b t)++-- | Modulate the amplitude of one wave with another. This is simply pointwise multiplication:+-- @+--  'amplitudeModulate' = 'modulate' ('*')+-- @+amplitudeModulate :: Num a => Waveform t a -> Waveform t a -> Waveform t a+amplitudeModulate = modulate (*)++-- | Modulate the phase of one wave with another. Used in synthesis.+-- @+--  'phaseModulate' beta ('setVolume' 0.2 $ 'sinWave' 'concertA') ('setVolume' 0.38 $ 'triWave' 'concertA')+-- @+-- (try beta=0.0005)+phaseModulate :: Num t +              => t -- ^ Tuning parameter. Modulation signal is @'amplitudeModulate'@d by @('const' beta)@+              -> Waveform t t -- ^ Modulation signal. Outputs the phase shift to apply+              -> Waveform t a -- ^ Target wave to be modulated+              -> Waveform t a+phaseModulate beta modulation target = sampleFrom $ \t -> sample target (t + beta * sample modulation t)++-- | Smoothly transition to playing a wave back at a different speed after some time+changeSpeed :: (Ord a,Fractional a) => a -> a -> a -> Waveform a a -> Waveform a a+changeSpeed startTime lerpTime newSpeed wave = sampleFrom $ \t -> sample wave $ if t < startTime+  then t+  else if t > startTime + lerpTime+    then startTime + newSpeed * t+    -- Lerp between sampling at 1 and sampling at newSpeed+    else startTime + (1 + ((t - startTime)/lerpTime) * (newSpeed - 1)) * t++-- | Play several waves on top of each other, normalizing so that e.g. playing three notes together doesn't triple the volume.+balanceChord :: Fractional a => [Waveform t a] -> Waveform t a+balanceChord notes = sampleFrom $ \t -> sum . map ((/ fromIntegral chordSize) . sampleAt t) $ notes+  where+    chordSize = length notes++-- | Play several waves on top of each other, without worrying about the volume. See 'balanceChord' for+-- a normalized version.+mergeWaves :: Fractional a => [Waveform t a] -> Waveform t a+mergeWaves notes = sampleFrom $ \t -> sum (map (sampleAt t) notes)+  -- Average Frequency+  --,frequency = fmap (/(fromIntegral $ length notes)) . foldl (liftA2 (+)) (Just 0) . map frequency $ notes++-- | @'waveformToWAVE' outputLength@ gives a @'WAVE'@ file object by sampling the given @'DWave'@ at @44100Hz@.+-- May disbehave or clip based on behavior of @'doubleToSample'@ if the DWave takes values outside of @[-1,1]@.+waveformToWAVE :: Double -> DWave -> WAVE+waveformToWAVE outTime w = WAVE+  {waveHeader = WAVEHeader+    {waveNumChannels = 1+    ,waveFrameRate = sampleRate+    ,waveBitsPerSample = 32+    ,waveFrames = Just $ numFrames+    }+  ,waveSamples = [map (doubleToSample . sample w . (/sampleRate)) [0 .. fromIntegral (numFrames - 1)]]+  }+  where+    sampleRate :: Num a => a+    sampleRate = 44100+    numFrames = ceiling $ outTime * sampleRate++-- | Triangle wave of the given frequency+triWave :: (Ord a,RealFrac a) => a -> Waveform a a+triWave f = sampleFrom $ \t -> let r = (t * f) - fromIntegral (floor (t * f)) in if r < 0.25+  then 4 * r+  else if r < 0.75+    then 2 - (4 * r)+    else -4 + (4 * r)++-- | Output the first ten seconds of the given @'DWave'@ to the file @test.wav@ for testing.+-- The volume is also attenuated by 50% to not blow out your eardrums.+-- Also pretty prints the wave.+testWave :: DWave -> IO ()+testWave w = print w >> pure w >>= putWAVEFile "test.wav" . waveformToWAVE 10 . amplitudeModulate (sampleFrom $ const 0.5)++-- | Outputs a sound test of the given @'PitchFactorDiagram'@ as an interval above @'concertA'@ as a @'sinWave'@ to the file @diag.wav@ for testing.+testDiagram :: PitchFactorDiagram -> IO ()+testDiagram = putWAVEFile "diag.wav" . waveformToWAVE 3 . buildTestTrack . realToFrac . diagramToRatio . normalizePFD+  where+    buildTestTrack p = sequenceNotes [((0,1),sinWave concertA),((1,2),sinWave (concertA * p)),((2,3), buildChord [1,p] concertA)]++-- | Converts a rhythm of @'DWave'@ notes to a combined @'DWave'@ according to the timing rules of @'Beat'@.+sequenceToBeat :: Double -> Double -> Beat DWave -> DWave+sequenceToBeat startAt totalLength (RoseBeat bs) = let dt = totalLength / genericLength bs in fst $ foldl (\(w,i) b -> (mergeWaves . (:[w]) . sequenceToBeat (i * dt) dt $ b,i+1)) (sampleFrom $ const 0,0) bs+sequenceToBeat startAt totalLength Rest = sampleFrom $ const 0+sequenceToBeat startAt totalLength (Beat w) = modulateMuting (compactWave (startAt,startAt + totalLength)) $ timeShift startAt w++-- | Sequences some waves to play on the given time intervals.+sequenceNotes :: (Ord t,Fractional t,Fractional a) => [((t,t),Waveform t a)] -> Waveform t a+sequenceNotes = mergeWaves . map (\(t,w) -> modulateMuting (compactWave t) $ timeShift (fst t) w)++-- | Builds a chord out of the given ratios relative to the root pitch+-- @+--  buildChord ratios root+-- @+buildChord :: [Double] -> Double -> DWave+buildChord relPitches root = balanceChord $ map (triWave . (root *)) relPitches++-- | Builds a chord out of the given ratios relative to the root pitch, without normalizing the volume.+-- (Warning: may be loud)+buildChordNoBalance :: [Double] -> Double -> DWave+buildChordNoBalance relPitches root = mergeWaves $ map (triWave . (root *)) relPitches++-- | Builds a just-intonated major chord over the given root pitch+majorChordOver :: Double -> DWave+majorChordOver = buildChord+  [1+  ,diagramToRatio majorThird+  ,diagramToRatio perfectFifth+  ]++-- | Builds an equal temperament minor chord over the given root pitch+minorChordOver :: Double -> DWave+minorChordOver = buildChord+  [semi ** 0+  ,semi ** 3+  ,semi ** 7+  ]++-- | Concert A4 frequency is 440Hz+concertA :: Num a => a+concertA = 440++-- | Build an envelope waveform with the given parameters: Predelay Time, Attack Time, Hold Time, Decay Time, Sustain Level, Release Time+envelope :: Double -> Double -> Double -> Double -> Double -> Double -> DWave+envelope del att hol dec sus rel = sampleFrom $ \t -> if t < del+  then 0+  else if t - del < att+    then (t - del) / att+    else if t - del - att < hol+      then 1+      else if t - del - att - hol < dec+        then 1 + (t - del - att - hol)/dec * (sus - 1)+        else if t - del - att - hol - dec < rel+          then sus * (1 - (t - del - att - hol - dec)/rel)+          else 0++-- | Shift a wave in time to start at the specified time after its old start time+timeShift :: Num t => t -> Waveform t a -> Waveform t a+timeShift dt = sampleFrom . (. subtract dt) . sample++-- | Play several waves in a row with eqqual time each, using @'sequenceNotes'@.+equalTime :: Double -> [DWave] -> DWave+equalTime dt = sequenceNotes . foldl go []+  where+    go xs@(((_,t1),_):_) k = ((t1,t1 + dt),k):xs+    go [] k = [((0,dt),k)]++-- | Modify the amplitude of a wave by a constant multiple+setVolume :: Num a => a -> Waveform t a -> Waveform t a+setVolume = amplitudeModulate . sampleFrom . const++-- | The empty wave that is always zero when sampled+emptyWave :: Num a => Waveform t a+emptyWave = sampleFrom $ const 0
+ src/Boopadoop/Diagram.hs view
@@ -0,0 +1,101 @@+-- | Tools for creating and manipulation Pitch Factor Diagrams, a tool for representing musical 
+-- intervals and examining their relations.
+module Boopadoop.Diagram where
+
+import Data.Ratio
+import Data.Bits
+import Data.Monoid
+import Data.List
+import Data.Numbers.Primes
+import Data.Align (salign)
+
+-- | 12 tone equal temperament semitone ratio. Equal to @2 ** (1/12)@.
+semi :: Floating a => a
+semi = 2 ** (1/12)
+
+-- | 12 tone equal temperament ratios for all semitones in an octave.
+allSemis :: Floating a => [a]
+allSemis = map (semi **) . map fromIntegral $ [0..11 :: Int]
+
+-- | List multiples of the single octave semitone ratios upto a certain amount.
+takeFinAlignments :: Floating a => Int -> [[a]]
+takeFinAlignments fin = map (\k -> map (*k) . map fromIntegral $ [1.. fin]) allSemis
+
+-- | A pitch factor diagram is a list of prime exponents that represents a rational number
+-- via 'diagramToRatio'. These are useful because pitches with few prime factors, that is,
+-- small 'PitchFactorDiagram's with small factors in them, are generally consonant, and
+-- many interesting just intonation intervals can be written this way (see 'Boopadoop.Interval.perfectFifth'
+-- and 'Boopadoop.Interval.majorThird').
+newtype PitchFactorDiagram = Factors {getFactors :: [Integer]} deriving Show
+
+-- | 'mempty' is the unison PFD, with ratio @1@.
+instance Monoid PitchFactorDiagram where
+  mempty = Factors []
+  mappend = addPFD
+-- | 'PitchFactorDiagram's are combined by multiplying their underlying ratios (adding factors).
+instance Semigroup PitchFactorDiagram where
+  (<>) = addPFD
+
+-- | Convert a factor diagram to the underlying ratio by raising each prime (starting from two) to the power in the factor list. For instance, going up two perfect fifths and down three major thirds yields:
+-- @
+--  diagramToRatio (Factors [4,2,-3]) = (2 ^^ 4) * (3 ^^ 2) * (5 ^^ (-3)) = 144/125
+-- @
+diagramToRatio :: Fractional a => PitchFactorDiagram -> a
+diagramToRatio = product . zipWith (^^) (map fromIntegral primes) . getFactors
+
+-- | Similar to 'diagramToRatio', but simplifies the resulting ratio to the simplest ratio within @0.05@.
+diagramToFloatyRatio :: PitchFactorDiagram -> Rational
+diagramToFloatyRatio = flip approxRational 0.05 . diagramToRatio
+
+-- | Convert a PFD to its decimal number of semitones. Useful for approximating weird ratios in a twelvetone scale:
+-- @
+--  diagramToSemi (normalizePFD $ Factors [0,0,0,1]) = diagramToSemi (countPFD (7/4)) = 9.688259064691248
+-- @
+diagramToSemi :: Floating a => PitchFactorDiagram -> a
+diagramToSemi = (12 *) . logBase 2 . realToFrac . diagramToRatio . normalizePFD
+
+-- | Normalize a PFD by raising or lowering it by octaves until its ratio lies between @1@ (unison) and @2@ (one octave up).
+-- This operation is idempotent.
+normalizePFD :: PitchFactorDiagram -> PitchFactorDiagram
+normalizePFD (Factors []) = Factors []
+normalizePFD (Factors (_:xs)) = Factors $ (negate . floor . logBase 2 . realToFrac . diagramToRatio . Factors . (0:) $ xs) : xs
+
+-- | Same as 'countPFD' but makes an effort to simplify the ratio from a 'Double' slightly to the simplest rational number within @0.0001@.
+countPFDFuzzy :: Double -> PitchFactorDiagram
+countPFDFuzzy = countPFD . flip approxRational 0.0001
+
+-- | Calculates the 'PitchFactorDiagram' corresponding to a given frequency ratio by finding prime factors of the numerator and denominator.
+countPFD :: Rational -> PitchFactorDiagram
+countPFD k = Factors $ go (primeFactors $ numerator k,primeFactors $ denominator k) primes
+  where
+    count = (genericLength .) . filter
+    go :: ([Integer],[Integer]) -> [Integer] -> [Integer]
+    go ([],[]) _ = []
+    go (nfs,dfs) (p:ps) = count (==p) nfs - count (==p) dfs : go (filter (/=p) nfs,filter (/=p) dfs) ps
+
+-- | Converts a PFD into an operation on frequencies. @'intervalOf' 'Boopadoop.Interval.perfectFifth' 'Boopadoop.concertA'@ is the just intonation E5.
+intervalOf :: PitchFactorDiagram -> (Double -> Double)
+intervalOf = (*) . (realToFrac . diagramToRatio)
+
+-- | Scale a PFD by raising the underlying ratio to the given power. @'scalePFD' 2 'Boopadoop.Interval.perfectFifth' = 'addPFD' 'Boopadoop.Interval.octave' 'Boopadoop.Interval.majorSecond'@
+scalePFD :: Integer -> PitchFactorDiagram -> PitchFactorDiagram
+scalePFD lambda = Factors . map (*lambda) . getFactors
+
+-- | Inverts a PFD. @'invertPFD' = 'scalePFD' (-1)@
+invertPFD :: PitchFactorDiagram -> PitchFactorDiagram
+invertPFD = scalePFD (-1)
+
+-- | Adds two PFDs together by multiplying their ratios. @'addPFD' minorThird 'Boopadoop.Interval.majorThird' = 'Boopadoop.Interval.perfectFifth'@
+addPFD :: PitchFactorDiagram -> PitchFactorDiagram -> PitchFactorDiagram
+addPFD a b = Factors . map getSum $ salign (map Sum $ getFactors a) (map Sum $ getFactors b)
+
+-- | Prints the natural numbers from the given value up to @128@, highlighting primes and powers of two.
+-- Interesting musical intervals are build out of the relative distance of a prime between the two
+-- nearest powers of two.
+printTheSequence :: Int -> IO ()
+printTheSequence k 
+  | k > 128 = putStrLn ""
+  | k .&. (k-1) == 0 = putStr ("|\n[" ++ show k ++ "]") >> printTheSequence (k+1)
+  | isPrime k = putStr ("(" ++ show k ++ ")") >> printTheSequence (k+1)
+  | otherwise = putStr " . " >> printTheSequence (k+1)
+
+ src/Boopadoop/Example.hs view
@@ -0,0 +1,46 @@+module Boopadoop.Example where
+
+import Boopadoop
+
+testProg :: DWave
+testProg = sequenceNotes
+  [((1,2),buildChord [4/4,5/4,6/4] (concertA * semi ** 0))
+  ,((2,3),buildChord [5/5,6/5,7/5] (concertA * semi ** 0))
+  ,((3,4),buildChord [6/6,7/6,8/6] (concertA * semi ** 0))
+  ,((4,5),buildChord [semi ** (-5), semi ** 0, semi ** 4] (concertA * semi ** 7))
+  ]
+
+testDoot :: DWave
+testDoot = amplitudeModulate (envelope 0.5 0.15 0 0.25 0.1 3) $ triWave concertA
+
+wackRatio :: DWave
+wackRatio = sequenceNotes
+  [((0,2),sinWave concertA)
+  ,((2,3),buildChord [4/4,5/4,6/4] concertA)
+  ,((3,4),sinWave concertA)
+  ,((4,5),sinWave (concertA * 7 / 4))
+  ,((5,6),buildChord [4/4,7/4] concertA)
+  ,((6,7),buildChord [4/4,5/4,7/4] concertA)
+  ,((7,8),buildChord [4/4,5/4,6/4,7/4] concertA)
+  ]
+
+tripleOscEmulation :: Double -> DWave
+tripleOscEmulation f = balanceChord
+  [sinWave f
+  ,sinWave $ intervalOf (scalePFD (-1) octave) f
+  ,sinWave $ intervalOf (scalePFD (-2) octave) f
+  ]
+
+tiptoeEnvelope :: DWave
+tiptoeEnvelope = envelope 0 0.052 0 0.393 0.0418 0.432
+
+tiptoeEmulation :: Double -> DWave
+tiptoeEmulation f = amplitudeModulate tiptoeEnvelope $ phaseModulate 0.005 (setVolume 0.2 $ sinWave f) (setVolume 0.38 $ triWave f)
+{- LMMS Envelope XML:
+<elvol lshp="0" latt="0" x100="0" rel="0.432" lpdel="0" lspd_denominator="4" ctlenvamt="0" lspd_numerator="4" lamt="0" lspd_syncmode="0" hold="0" amt="1" sustain="0.101" lspd="0.0418" att="0.052" pdel="0" userwavefile="" dec="0.393"/>
+-}
+
+
+downBeat :: Beat DWave
+downBeat = RoseBeat [Beat (sinWave concertA),Rest,Beat (sinWave $ intervalOf perfectFifth concertA)]
+
+ src/Boopadoop/Interval.hs view
@@ -0,0 +1,36 @@+-- | Some common musical intervals written as @'PitchFactorDiagram'@s
+module Boopadoop.Interval where
+
+import Boopadoop.Diagram
+
+-- | Interval of one octave, ratio is 2.
+octave :: PitchFactorDiagram
+octave = Factors [1]
+
+-- | Interval of a perfect fifth 3:2
+perfectFifth :: PitchFactorDiagram
+perfectFifth = normalizePFD $ Factors [0,1]
+
+-- | Interval of a major third 5:4
+majorThird :: PitchFactorDiagram
+majorThird = normalizePFD $ Factors [0,0,1]
+
+-- | Interval 7:4
+mysterySeven :: PitchFactorDiagram
+mysterySeven = normalizePFD $ Factors [0,0,0,1]
+
+-- | Interval of a major second 9:8
+majorSecond :: PitchFactorDiagram
+majorSecond = normalizePFD $ Factors [0,2]
+
+-- | Interval 25:16
+mystery25 :: PitchFactorDiagram
+mystery25 = normalizePFD $ Factors [0,0,2]
+
+-- | Interval 199:200. Should be mostly consonant to your ear but has non-small PFD:
+-- @
+--  [-3,0,-2,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1]
+-- @
+counterExample :: PitchFactorDiagram
+counterExample = Factors $ [-3,0,-2] ++ take 42 (repeat 0) ++ [1]
+
+ src/Boopadoop/Rhythm.hs view
@@ -0,0 +1,39 @@+-- | Representing rhythms as rose trees.
+module Boopadoop.Rhythm where
+
+import Data.Numbers.Primes
+import Data.List.Split
+
+-- | A rhythm is represented as a rose tree where each subtree is given equal amounts of time.
+-- Leaves are either a Beat of type @a@ or empty (a rest).
+data Beat a = RoseBeat [Beat a] | Beat a | Rest
+
+-- | Class for things that can be summarized in a single character, for use in printing out rhythms.
+class SummaryChar a where
+  sumUp :: a -> Char
+
+-- | Show the rhythm by printing the summary characters, or @'.'@ for rests.
+instance SummaryChar a => Show (Beat a) where
+  show (RoseBeat bs) = "[" ++ (bs >>= show) ++ "]"
+  show (Beat x) = [sumUp x]
+  show Rest = "."
+
+-- | A rack of drums. Simple enumeration of the different possible drum types.
+data DrumRack = Kick | Snare
+
+instance SummaryChar DrumRack where
+  sumUp Kick = 'O'
+  sumUp Snare = 'x'
+
+-- | The standard rock beat (or half of it) played on the 'DrumRack'
+rockBeat :: Beat DrumRack
+rockBeat = RoseBeat [Beat Kick, Rest, Beat Snare, Rest]
+
+-- | Force there to be only prime divisions of time in the rhythm.
+-- This is done without affecting the actual rhythm.
+-- This operation is not uniquely valued in any way, and this algorithm prefers small primes first.
+primeBeat :: Beat a -> Beat a
+primeBeat (RoseBeat bs)
+  | isPrime (length bs) = RoseBeat $ map primeBeat bs
+  | otherwise = let (pf:_) = reverse $ primeFactors (length bs) in primeBeat . RoseBeat . map RoseBeat $ chunksOf pf bs
+primeBeat x = x
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"