music-pitch 1.7.1 → 1.7.2

raw patch · 11 files changed

+832/−235 lines, 11 filesdep +natsdep +type-unarydep +vector-space-pointsdep ~music-pitch-literalPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: nats, type-unary, vector-space-points

Dependency ranges changed: music-pitch-literal

API changes (from Hackage documentation)

Files

• music-pitch.cabal +11/−9
• src/Music/Pitch.hs +8/−5
• src/Music/Pitch/Absolute.hs +62/−2
• src/Music/Pitch/Clef.hs +89/−0
• src/Music/Pitch/Common/Interval.hs +350/−189
• src/Music/Pitch/Common/Pitch.hs +23/−8
• src/Music/Pitch/Common/Semitones.hs +26/−11
• src/Music/Pitch/Common/Spell.hs +2/−2
• src/Music/Pitch/Equal.hs +109/−0
• src/Music/Pitch/Intonation.hs +87/−9
• src/Music/Pitch/StaffLines.hs +65/−0

@@ -1,12 +1,12 @@  name:                   music-pitch-version:                1.7.1+version:                1.7.2 cabal-version:          >= 1.10 author:                 Hans Hoglund maintainer:             Hans Hoglund license:                BSD3 license-file:           COPYING-synopsis:               Abstract representation of musical pitch.+synopsis:               Musical pitch representation. category:               Music tested-with:            GHC build-type:             Simple@@ -14,11 +14,6 @@ description:      This package provides various representations of musical pitch.     .-    Note that this package is independent of @music-score@ and vice versa.-    This is a deliberate design choice: the user should be free to combine any-    pitch representation with any time structure. Normally you will include-    both packages through @music-preludes@.-    .     This library is part of the Music Suite, see     <http://music-suite.github.io>. @@ -33,16 +28,23 @@                         containers,                         semigroups              >= 0.13.0.1 && < 1,                         semigroupoids,-                        music-pitch-literal     == 1.7.1,-                        vector-space            >= 0.8.7 && < 0.9+                        music-pitch-literal     == 1.7.2,+                        vector-space            >= 0.8.7 && < 0.9,+                        vector-space-points     >= 0.2 && < 0.3,+                        nats,+                        type-unary              >= 0.2.16 && < 1.0+                        -- type-level              >= 0.2.4 && < 3.0     exposed-modules:    Music.Pitch                         Music.Pitch.Absolute+                        Music.Pitch.Equal                         Music.Pitch.Common                         Music.Pitch.Common.Interval                         Music.Pitch.Common.Pitch                         Music.Pitch.Common.Semitones                         Music.Pitch.Common.Spell                         Music.Pitch.Common.Harmony+                        Music.Pitch.StaffLines+                        Music.Pitch.Clef                         Music.Pitch.Tokawa                         Music.Pitch.Intonation     hs-source-dirs:     src

@@ -9,11 +9,7 @@ -- Stability   : experimental -- Portability : non-portable (TF,GNTD) ----- The "music-pitch" package provides several pitch and interval types. ------ See 'Pitch' and 'Interval' for common--- representations. If you want to use an alternative represention, import the relevant--- submodule.+-- Provides various representations of musical pitches and intervals.  -- ------------------------------------------------------------------------------------- @@ -22,6 +18,7 @@         module Data.Semigroup,         module Data.VectorSpace,         module Data.AffineSpace,+        module Data.AffineSpace.Point,          -- * Pitch representation         @@ -39,6 +36,9 @@         -- --   Includes representation of common practice pitches and intervals such as /c sharp/,          -- --   /diminished second/ and so on.         module Music.Pitch.Common,++        -- * Intonation+        module Music.Pitch.Intonation,                  -- * Pitch literals         module Music.Pitch.Literal,@@ -47,9 +47,12 @@ import Data.Semigroup import Data.VectorSpace hiding (Sum, getSum) import Data.AffineSpace+import Data.AffineSpace.Point  import Music.Pitch.Absolute import Music.Pitch.Augmentable import Music.Pitch.Alterable import Music.Pitch.Common import Music.Pitch.Literal+import Music.Pitch.Intonation+

@@ -1,5 +1,5 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies #-}  ------------------------------------------------------------------------------------- -- |@@ -20,6 +20,7 @@  module Music.Pitch.Absolute (         Hertz(..),+        -- FreqRatio(..),         -- Octaves,         Cents,         Fifths,@@ -32,16 +33,29 @@ import Data.Maybe import Data.Either import Data.Semigroup+import Data.VectorSpace+import Data.AdditiveGroup+import Data.AffineSpace import Control.Monad import Control.Applicative +import Music.Pitch.Literal+ -- |  -- Absolute frequency in Hertz.     --  newtype Hertz = Hertz { getHertz :: Double }     deriving (Read, Show, Eq, Enum, Num, Ord, Fractional, Floating, Real, RealFrac) +{- -- | +-- A ratio between two different (Hertz) frequencies.+-- +newtype FreqRatio = FreqRatio { getFreqRatio :: Double }+    deriving (Read, Show, Eq, Enum, Num, Ord, Fractional, Floating, Real, RealFrac)+-}++-- |  -- Number of pure octaves. -- -- Octaves are a logarithmic representation of frequency such that@@ -82,6 +96,35 @@ instance Monoid Fifths      where { mempty  = 0 ; mappend = (+) } instance Monoid Cents       where { mempty  = 0 ; mappend = (+) } +{-+instance AdditiveGroup FreqRatio where+    zeroV   = 1+    (^+^)   = (*)+    negateV f = 1 / f++instance VectorSpace FreqRatio where+    type Scalar FreqRatio = Double+    (*^) x f = FreqRatio ((getFreqRatio f) ** x)++instance AffineSpace Hertz where+  type Diff Hertz = FreqRatio+  (.-.) f1 f2 = FreqRatio $ (getHertz f1) / (getHertz f2)+  (.+^) p f = Hertz $ (getHertz p) * (getFreqRatio f)+-}+instance AdditiveGroup Hertz where+    zeroV   = 1+    (^+^)   = (*)+    negateV f = 1 / f++instance VectorSpace Hertz where+    type Scalar Hertz = Hertz+    (*^) x f = Hertz ((getHertz f) ** getHertz x)++instance AffineSpace Hertz where+  type Diff Hertz = Hertz+  (.-.) = (-)+  (.+^) = (+)+ class HasFrequency a where     frequency :: a -> Hertz @@ -106,5 +149,22 @@ cents :: HasFrequency a => a -> Cents cents a = Cents $ logBase (2/1) (frequency a) * 1200 +-- +-- For convenience. TODO problematic for these reasons:+-- +--  * Confusing as _P8+m2 is not the same as _P8<>m2+--  * Does not work with HasPitch (up, down...) etc as we do not have an affine/vector space pair+--+-- Can we fix this with newtype wrappers?+-- +instance IsInterval Hertz where+  fromInterval (IntervalL (o,d,c)) = (2**fromIntegral o) * (r !! fromIntegral c)+    where+      r = [+        1/1,+        (8*2)/15, 9/8,      (2*3)/5, 5/4,     (2*2)/3,+        10/7,+        3/2,      (4*2)/5,  5/3,     (2*8)/9, 15/8+        ] -                             +

@@ -0,0 +1,89 @@++{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeFamilies               #-}++module Music.Pitch.Clef (+      ClefSymbol,+      OctaveAdjustment,+      Clef,+      symbolName,+      symbolPitch,+      positionPitch,+      pitchPosition,+  ) where++import Data.Typeable++import Music.Pitch.StaffLines+import Music.Pitch.Common+import Music.Pitch.Literal++data ClefSymbol = GClef | CClef | FClef | PercClef | NeutralClef+    deriving (Eq, Ord, Show, Typeable)++type OctaveAdjustment = Integer++type Clef = (ClefSymbol, OctaveAdjustment, StaffLines)++symbolName :: ClefSymbol -> String+symbolName GClef = "G clef"+symbolName CClef = "C clef"+symbolName FClef = "F clef"+symbolName PercClef = "Percussion clef"+symbolName NeutralClef = "Neutral clef"++symbolPitch :: ClefSymbol -> Maybe Pitch+symbolPitch GClef = Just g+symbolPitch CClef = Just c+symbolPitch FClef = Just f+symbolPitch _     = Nothing++-- TODO consolidate with common+pitchPosition :: Clef -> Pitch -> Maybe StaffLines+pitchPosition (s,o,l) x = undefined+  where+    numbersPerOctave = 7+    referencePitch = symbolPitch s :: Maybe Pitch++positionPitch :: Clef -> StaffLines -> Maybe Pitch+positionPitch (s,o,l) x = fmap (upDiatonic relativePosition) referencePitch+  where+    numbersPerOctave = 7+    referencePitch = symbolPitch s :: Maybe Pitch+    relativePosition = fromIntegral $ (x - l) + fromIntegral (o*7)++-- TODO implement fully in Pitch.Common.Diatonic+upDiatonic :: Number -> Pitch -> Pitch+upDiatonic = error "Not implemented: upDiatonic"++{-+TODO++IsPitch instance?+  What to do with the non-standard pitches, i.e.+  we know what (g :: ClefSymbol) is, but what about (cs :: ClefSymbol)?+  I think 1) error or 2) default to g.++Map this to Pitch.Common+  Do we make this module 1) depend on Pitch.Common or 2) the other way around?+  If 1), do we need to separate G/C/F in ClefSymbol, maybe just put a single constructor for common pitch.+  In that case, maybe a function isStandardClefPitch (i.e. c/f/g) would be appropriate.+-}+++-- isModernClef :: Clef -> Bool+-- isHistoricalClef :: Clef -> Bool++-- i.e. a c clef on some staff+-- isVoiceClef :: Clef -> Bool+

@@ -4,7 +4,7 @@  ------------------------------------------------------------------------------------ -- |--- Copyright   : (c) Hans Hoglund 2012+-- Copyright   : (c) Hans Hoglund, Edward Lilley 2012–2014 -- -- License     : BSD-style --@@ -46,9 +46,9 @@         thirteenth,         fourteenth,         fifteenth,  -        +         -- ** Intervals-        Interval,+        Interval(..),          -- *** Creating intervals         mkInterval,@@ -61,7 +61,6 @@         doublyDiminished,          -- *** Inspecting intervals-        octaves,         isNegative,         isPositive,         isNonNegative,@@ -74,12 +73,30 @@         isCompound,         separate,         simple,+        octaves,          -- *** Inversion         invert,          -- * Utility         asInterval,++        -- * Basis values+        IntervalBasis(..),+       +        -- ** Converting basis+        convertBasis,+        convertBasisFloat,+        intervalDiv,+        +        -- ** Basis values (TODO cleanup)+        basis_P1,+        basis_A1,+        basis_d2,+        basis_P8,+        basis_P5,+        +        -- ** Utility         intervalDiff,         mkInterval',   ) where@@ -88,7 +105,8 @@ import Data.Either import Data.Semigroup import Data.VectorSpace-import Data.AffineSpace+-- import Data.AffineSpace+import Data.Basis import Data.Typeable import Control.Monad import Control.Applicative@@ -108,47 +126,41 @@ -- The quality of a compound interval is the quality of the simple interval on -- which it is based. --+-- Note that (Augmented 0) and (Diminished 0) are superfluous identity+-- values, use Perfect instead. Augmented and Diminished must also+-- take only positive arguments.+ data Quality     = Major     | Minor     | Perfect-    | Augmented Integer-    | Diminished Integer+    | Augmented Int+    | Diminished Int     deriving (Eq, Ord, Show)  instance HasQuality Quality where     quality = id --- There is no instance for (Augmentable Quality) as we can not distinguish --- between m/M and P in cases like (augment $ Diminished 1) or --- (diminish $ Augmented 1). --- instance Augmentable Quality where---     augment = go---         where---             go (Diminished 0)   = error "Diminished 0"---             go (Diminished 1)   = Minor -- Or perfect---             go (Diminished n)   = Diminished (n - 1)--- ---             go Minor            = Major---             go Perfect          = Augmented 1---             go Major            = Augmented 1--- ---             go (Augmented 0)    = error "Augmented 0"---             go (Augmented n)    = Augmented (n + 1)---     diminish = go---         where---             go (Diminished 0)   = error "Diminished 0"---             go (Diminished n)   = Diminished (n + 1)--- ---             go Major            = Minor---             go Perfect          = Diminished 1---             go Minor            = Diminished 1+-- | Augmentable Quality instance -- ---             go (Augmented 0)    = error "Augmented 0"---             go (Augmented 1)    = Major -- or Perfect (?)---             go (Augmented n)    = Augmented (n - 1)+-- This Augmentable instance exists solely for use of the getQuality+-- function, which ensures that there is never any ambiguity around+-- diminished/augmented intervals turning into major/minor/perfect+-- intervals. +instance Augmentable Quality where+  augment Major = Augmented 1+  augment Minor = Major+  augment Perfect = Augmented 1+  augment (Augmented n) = Augmented (n + 1)+  augment (Diminished n) = Diminished (n - 1)+  diminish Major = Minor+  diminish Minor = Diminished 1+  diminish Perfect = Diminished 1+  diminish (Augmented n) = Augmented (n - 1)+  diminish (Diminished n) = Diminished (n + 1)+ class HasQuality a where     quality :: a -> Quality @@ -198,38 +210,6 @@ isDiminished :: HasQuality a => a -> Bool isDiminished a = case quality a of { Diminished _ -> True ; _ -> False } --- Convert an offset to a quality.------ This is different for perfect and imperfect interals:------      Imperfect   Perfect---      ===         ===--- -3   dd          ddd--- -2   d           dd--- -1   m           d---  0   M           P---  1   a           a---  2   aa          aa----diffToQuality :: Bool -> Int -> Quality-diffToQuality = go-    where-        go True  0   = Perfect-        go True  n   = if n > 0 then Augmented (fromIntegral n) else Diminished (fromIntegral $ negate n)-        go False 0    = Major-        go False (-1) = Minor-        go False n    = if n > 0 then Augmented (fromIntegral n) else Diminished (fromIntegral $ negate $ n + 1)--qualityToDiff :: Bool -> Quality -> Int-qualityToDiff perfect = go-    where-        go (Diminished n)   = fromIntegral $ negate $ if perfect then n else n + 1-        go Minor            = fromIntegral $ -1-        go Perfect          = fromIntegral $ 0-        go Major            = fromIntegral $ 0-        go (Augmented n)    = fromIntegral $ n-- -- | -- The number portion of an interval (i.e. second, third, etc). --@@ -239,7 +219,7 @@ -- -- > number (a + b) = number a + number b - 1 ---newtype Number = Number { getNumber :: Integer }+newtype Number = Number { getNumber :: Int }     deriving (Eq, Ord, Num, Enum, Real, Integral)      instance Show Number where { show = show . getNumber }@@ -250,67 +230,67 @@ unison      :: Number unison      = 1 --- | A synonym for @2@.+-- | A synonym for @1@. prime       :: Number prime       = 1 --- | A synonym for @3@.+-- | A synonym for @2@. second      :: Number second      = 2 --- | A synonym for @4@.+-- | A synonym for @3@. third       :: Number third       = 3 --- | A synonym for @5@.+-- | A synonym for @4@. fourth      :: Number fourth      = 4      --- | A synonym for @6@.+-- | A synonym for @5@. fifth       :: Number fifth       = 5 --- | A synonym for @7@.+-- | A synonym for @6@. sixth       :: Number sixth       = 6 --- | A synonym for @8@.+-- | A synonym for @7@. seventh     :: Number seventh     = 7 --- | A synonym for @9@.+-- | A synonym for @8@. octave      :: Number octave      = 8 --- | A synonym for @10@.+-- | A synonym for @9@. ninth       :: Number ninth       = 9 --- | A synonym for @11@.+-- | A synonym for @10@. tenth       :: Number tenth       = 10 --- | A synonym for @12@.+-- | A synonym for @11@. eleventh    :: Number eleventh    = 11 --- | A synonym for @13@.+-- | A synonym for @12@. twelfth     :: Number twelfth     = 12 --- | A synonym for @14@.+-- | A synonym for @12@. duodecim    :: Number duodecim    = 12 --- | A synonym for @15@.+-- | A synonym for @13@. thirteenth  :: Number thirteenth  = 13 --- | A synonym for @16@.+-- | A synonym for @14@. fourteenth  :: Number fourteenth  = 14 --- | A synonym for @17@.+-- | A synonym for @15@. fifteenth   :: Number fifteenth   = 15 @@ -341,7 +321,7 @@ -- > m3 ^+^ _M3 = _P5 -- > d5 ^+^ _M6 = m10 ----- The scalar type of 'Interval' is 'Integer', using '^*' to stack intervals of a certain+-- The scalar type of 'Interval' is 'Int', using '^*' to stack intervals of a certain -- type on top of each other. For example @_P5 ^* 2@ is a stack of 2 perfect fifths, or a -- major ninth. The 'Num' instance works as expected for '+', 'negate' and 'abs', and -- (arbitrarily) uses minor seconds for multiplication. If you find yourself '*', or@@ -357,49 +337,30 @@ -- > d5  == diminished fifth == diminish (perfect fifth) -- newtype Interval = Interval { getInterval :: (-            Int,        -- octaves, may be negative-            Int,        -- diatonic remainder (positive) [0..6]-            Int         -- chromatic remainder (positive) [0..11]+            Int,        -- number of A1, i.e. chromatic steps+            Int        -- number of d2, i.e. diatonic steps     ) }     deriving (Eq, Ord, Typeable) +-- | Avoid using '(*)', or 'signum' on intervals. instance Num Interval where     (+)           = addInterval     negate        = negateInterval     abs a         = if isNegative a then negate a else a-    a * b         = fromIntegral (semitones a) `stackInterval` b-    signum a      = if isNegative a then (-m2) else (if isPositive a then m2 else _P1)-    fromInteger 0 = _P1--    -- fromInteger n = n `stackInterval` m2-    fromInteger n = case fromInteger n `divMod` 12 of-        (octave, chromatic) -> Interval (octave, sharpSpelling chromatic, chromatic)-        where-            -- Copied from Spellings (TODO factor out these)-            sharpSpelling = go-                where-                    go 0  = 0-                    go 1  = 0-                    go 2  = 1-                    go 3  = 1-                    go 4  = 2-                    go 5  = 3-                    go 6  = 3-                    go 7  = 4-                    go 8  = 4-                    go 9  = 5-                    go 10 = 5-                    go 11 = 6+    (*)           = error "Music.Pitch.Common.Interval: no overloading for (*)"+    signum        = error "Music.Pitch.Common.Interval: no overloading for signum"+    fromInteger   = error "Music.Pitch.Common.Interval: no overloading for fromInteger"          instance Show Interval where-    show a | isNegative a = "-" ++ showQuality (quality a) ++ show (abs $ number a)-           | otherwise    =        showQuality (quality a) ++ show (abs $ number a)-           where-               showQuality Major            = "_M"-               showQuality Minor            = "m"-               showQuality Perfect          = "_P"-               showQuality (Augmented n)    = "_" ++ replicate' n 'A'-               showQuality (Diminished n)   = replicate' n 'd'+  show a+    | isNegative a = "-" ++ showQuality (extractQuality a) ++ show (abs $ extractNumber a)+    | otherwise    =        showQuality (extractQuality a) ++ show (abs $ extractNumber a)+    where+      showQuality Major            = "_M"+      showQuality Minor            = "m"+      showQuality Perfect          = "_P"+      showQuality (Augmented n)    = "_" ++ replicate' n 'A'+      showQuality (Diminished n)   = replicate' n 'd'  instance Semigroup Interval where     (<>)    = addInterval@@ -417,39 +378,47 @@     type Scalar Interval = Integer     (*^) = stackInterval +-- TODO move+data IntervalBasis = Chromatic | Diatonic+  deriving (Eq, Ord, Show, Enum)++instance HasBasis Interval where+  type Basis Interval = IntervalBasis+  basisValue Chromatic = basis_A1+  basisValue Diatonic  = basis_d2+  decompose  (Interval (c,d)) = [(Chromatic, fromIntegral c), (Diatonic, fromIntegral d)]+  decompose' (Interval (c,d)) Chromatic = fromIntegral c+  decompose' (Interval (c,d)) Diatonic  = fromIntegral d+ instance HasQuality Interval where-    quality (Interval (o, d, c))-        | o >= 0    =                 diffToQuality (isPerfectNumber d) (c - diatonicToChromatic d)-        | otherwise = invertQuality $ diffToQuality (isPerfectNumber d) (c - diatonicToChromatic d)+  quality i = extractQuality i  instance HasNumber Interval where-    number (Interval (o, d, c)) = fromIntegral $ inc $ o * 7 + d-        where-            inc a = if a >= 0 then succ a else pred a+  number i = extractNumber i  instance Augmentable Interval where-    augment  (Interval (o, d, c)) = Interval (o, d, c + 1)-    diminish (Interval (o, d, c)) = Interval (o, d, c - 1)---- |--- Returns the non-simple part of an interval.------ > (perfect octave)^*x + y = z  iff  y = simple z----octaves = fst . separate+  augment i = i ^+^ basis_A1+  diminish i = i ^-^ basis_A1  instance HasSemitones Interval where-    semitones (Interval (o, d, c)) = fromIntegral $ o * 12 + c+  semitones (Interval (a, d)) = fromIntegral a -- assuming "semitone" == A1  instance IsInterval Interval where-    fromInterval (IntervalL (o,d,c)) = Interval (fromIntegral o, fromIntegral d, fromIntegral c)+  fromInterval (IntervalL (o,d,c)) = (basis_P8^*o) ^+^ (basis_A1^*c) ^+^ (basis_d2^*d) --- |--- This is just the identity function, but is useful to fix the type of 'Interval'.----asInterval :: Interval -> Interval-asInterval = id+negateInterval :: Interval -> Interval+negateInterval (Interval (a, d)) = Interval (-a, -d) +addInterval :: Interval -> Interval -> Interval+addInterval (Interval (a1, d1)) (Interval (a2, d2)) = Interval (a1 + a2, d1 + d2)++stackInterval :: Integer -> Interval -> Interval+stackInterval n a | n >= 0    = mconcat $ replicate (fromIntegral n) a+                  | otherwise = negate $ stackInterval (negate n) a++intervalDiff :: Interval -> Int+intervalDiff (Interval (c, d)) = c - diatonicToChromatic d+ -- | -- Creates an interval from a quality and number. --@@ -457,16 +426,133 @@ -- major interval instead. Given 'Major' or 'Minor' with a number indicating a perfect -- consonance, 'interval' returns a perfect or diminished interval respectively. --+mkInterval' +  :: Int        -- ^ Difference in chromatic steps (?).+  -> Int        -- ^ Number of diatonic steps (NOT interval number).+  -> Interval+mkInterval' diff diatonic = Interval (diatonicToChromatic diatonic + diff, diatonic)++basis_P1 = Interval (0, 0)+basis_A1 = Interval (1, 0)+basis_d2 = Interval (0, 1)+basis_P5 = Interval (7, 4)+basis_P8 = Interval (12, 7)++ mkInterval :: Quality -> Number -> Interval-mkInterval quality number = mkInterval' (qualityToDiff (isPerfectNumber diatonic) quality) (fromIntegral number)-    where-        (_, diatonic) = (fromIntegral $ number - 1) `divMod` 7 -mkInterval' :: Int -> Int -> Interval-mkInterval' diff number = Interval (octave, diatonic, diatonicToChromatic diatonic + diff)-    where-        (octave, diatonic) = (number - 1) `divMod` 7+ -- our identity:+mkInterval Perfect 1 = basis_P1+ -- and our two basis vectors:+mkInterval (Augmented 1) 1 = basis_A1+mkInterval (Diminished 1) 2 = basis_d2 +mkInterval Minor 2 = basis_d2 ^+^ basis_A1+mkInterval Major 2 = (mkInterval Minor 2) ^+^ basis_A1+mkInterval (Augmented 1) 2 = (mkInterval Major 2) ^+^ basis_A1++mkInterval (Diminished 1) 3 = (mkInterval Minor 3) ^-^ basis_A1+mkInterval Minor 3 = (mkInterval Major 2) ^+^ (mkInterval Minor 2)+mkInterval Major 3 = (mkInterval Major 2) ^+^ (mkInterval Major 2)+mkInterval (Augmented 1) 3 =  (mkInterval Major 3) ^+^ basis_A1++mkInterval (Diminished 1) 4 = (mkInterval Perfect 4) ^-^ basis_A1+mkInterval Perfect 4 = (mkInterval Major 3) ^+^ (mkInterval Minor 2)+mkInterval (Augmented 1) 4 =  (mkInterval Perfect 4) ^+^ basis_A1++mkInterval (Diminished 1) 5 = (mkInterval Perfect 5) ^-^ basis_A1+mkInterval Perfect 5 = (mkInterval Perfect 4) ^+^ (mkInterval Major 2)+mkInterval (Augmented 1) 5 =  (mkInterval Perfect 5) ^+^ basis_A1++mkInterval (Diminished 1) 6 = (mkInterval Minor 6) ^-^ basis_A1+mkInterval Minor 6 = (mkInterval Perfect 5) ^+^ (mkInterval Minor 2)+mkInterval Major 6 = (mkInterval Perfect 5) ^+^ (mkInterval Major 2)+mkInterval (Augmented 1) 6 =  (mkInterval Major 6) ^+^ basis_A1++mkInterval (Diminished 1) 7 = (mkInterval Minor 7) ^-^ basis_A1+mkInterval Minor 7 = (mkInterval Major 6) ^+^ (mkInterval Minor 2)+mkInterval Major 7 = (mkInterval Major 6) ^+^ (mkInterval Major 2)+mkInterval (Augmented 1) 7 =  (mkInterval Major 7) ^+^ basis_A1++mkInterval Minor 1 = error "invalid interval"+mkInterval Major 1 = error "invalid interval"+mkInterval Perfect 2 = error "invalid interval"+mkInterval Perfect 3 = error "invalid interval"+mkInterval Minor 4 = error "invalid interval"+mkInterval Major 4 = error "invalid interval"+mkInterval Minor 5 = error "invalid interval"+mkInterval Major 5 = error "invalid interval"+mkInterval Perfect 6 = error "invalid interval"+mkInterval Perfect 7 = error "invalid interval"++mkInterval (Diminished 0) n = error "(Diminished 0) is not a valid Quality"+mkInterval (Augmented 0) n = error  "(Augmented 0) is not a valid Quality"++mkInterval (Diminished q) n = (mkInterval (Diminished (q - 1)) n) ^-^ basis_A1+mkInterval (Augmented q) n = (mkInterval (Diminished (q - 1)) n) ^+^ basis_A1++mkInterval q (Number n) = if n > 0+                          then (mkInterval q (Number (n - 7))) ^+^ basis_P8+                          else (mkInterval q (Number (n + 7))) ^-^ basis_P8+++-- |+-- Extracting the 'number' from an interval vector.+--+-- Note that (a, d) is a representation of the interval (a * A1) + (d+-- * d2), so the 'number' part of the interval must be stored entirely+-- in the d * d2 part (adding a unison, perfect or otherwise, can+-- never increase the number of the interval)+-- +extractNumber :: Interval -> Number+extractNumber (Interval (a, d))+  | d >= 0    = Number (d + 1)+  | otherwise = Number (d - 1)+++-- |+-- Extracting the 'quality' from an interval vector.+--+-- This is much more finicky, as the A1 and d2 intervals interact in a+-- complex way to produce the perfect/major/minor/etc. intervals that+-- we are used to reading.++extractQuality :: Interval -> Quality+extractQuality (Interval (a, d))+  | (a < 0) && (d == 0) = diminish (extractQuality (Interval ((a + 1), d)))+  | (a, d) == (0, 0) = Perfect+  | (a > 0) && (d == 0) = augment (extractQuality (Interval ((a - 1), d)))+  | (a < 1) && (d == 1) = diminish (extractQuality (Interval ((a + 1), d)))+  | (a, d) == (1, 1) = Minor+  | (a, d) == (2, 1) = Major+  | (a > 2) && (d == 1) = augment (extractQuality (Interval ((a - 1), d)))+  | (a < 3) && (d == 2) = diminish (extractQuality (Interval ((a + 1), d)))+  | (a, d) == (3, 2) = Minor+  | (a, d) == (4, 2) = Major+  | (a > 4) && (d == 2) = augment (extractQuality (Interval ((a - 1), d)))+  | (a < 5) && (d == 3) = diminish (extractQuality (Interval ((a + 1), d)))+  | (a, d) == (5, 3) = Perfect+  | (a > 5) && (d == 3) = augment (extractQuality (Interval ((a - 1), d)))+  | (a < 7) && (d == 4) = diminish (extractQuality (Interval ((a + 1), d)))+  | (a, d) == (7, 4) = Perfect+  | (a > 7) && (d == 4) = augment (extractQuality (Interval ((a - 1), d)))+  | (a < 8) && (d == 5) = diminish (extractQuality (Interval ((a + 1), d)))+  | (a, d) == (8, 5) = Minor+  | (a, d) == (9, 5) = Major+  | (a > 9) && (d == 5) = augment (extractQuality (Interval ((a - 1), d)))+  | (a < 10) && (d == 6) = diminish (extractQuality (Interval ((a + 1), d)))+  | (a, d) == (10, 6) = Minor+  | (a, d) == (11, 6) = Major+  | (a > 11) && (d == 6) = augment (extractQuality (Interval ((a - 1), d)))+  | (a < 12) && (d == 7) = diminish (extractQuality (Interval ((a + 1), d)))+  | (a, d) == (12, 7) = Perfect+  | (a > 12) && (d == 7) = augment (extractQuality (Interval ((a - 1), d)))+-- note: these last two cases *have* to be this way round, otherwise+-- infinite loop occurs.+  | (a > 12) || (d > 7) = extractQuality (Interval ((a - 12), (d - 7)))+  | (a < 0) || (d < 0) = extractQuality (Interval ((-a), (-d)))++ -- | Creates a perfect interval. --   If given an inperfect number, constructs a major interval. perfect :: Number -> Interval@@ -498,41 +584,45 @@ doublyDiminished :: Number -> Interval doublyDiminished = mkInterval (Diminished 2) --invertDiatonic :: Num a => a -> a-invertDiatonic d  = 7  - d--invertChromatic :: Num a => a -> a-invertChromatic c = 12 - c--negateInterval :: Interval -> Interval-negateInterval (Interval (o, 0, 0))    = Interval (negate o, 0, 0)-negateInterval (Interval (oa, da, ca)) = Interval (negate (oa + 1), invertDiatonic da, invertChromatic ca)--addInterval :: Interval -> Interval -> Interval-addInterval (Interval (oa, da,ca)) (Interval (ob, db,cb))-    = Interval (oa + ob + carry, steps, chroma)-    where-        (carry, steps) = (da + db) `divMod` 7-        chroma         = trunc (ca + cb)-        trunc          = if carry > 0 then (`mod` 12) else id--stackInterval :: Integer -> Interval -> Interval-stackInterval n a | n >= 0    = mconcat $ replicate (fromIntegral n) a-                  | otherwise = negate $ stackInterval (negate n) a+{- -intervalDiff :: Interval -> Int-intervalDiff (Interval (o, d, c)) = c - diatonicToChromatic d+Prelude Music.Prelude> separate (2*^_P8+m3)+(2,m3)+Prelude Music.Prelude> +Prelude Music.Prelude> separate (3*^_P8+m3)+(3,m3)+Prelude Music.Prelude> +Prelude Music.Prelude> separate (0*^_P8+m3)+(0,m3)+Prelude Music.Prelude> separate ((-1)*^_P8+m3) +-} -- | -- Separate a compound interval into octaves and a simple interval. -- -- > (perfect octave)^*x + y = z  iff  (x, y) = separate z -- separate :: Interval -> (Octaves, Interval)-separate (Interval (o, d, c)) = (fromIntegral o, Interval (0, d, c))+separate i = (fromIntegral o, i ^-^ (fromIntegral o *^ basis_P8))+  where+    o = octaves i  -- |+-- Returns the non-simple part of an interval.+--+-- > _P8^*octaves x ^+^ simple x = x+--+octaves :: Interval -> Octaves+octaves i +  | isNegative i && not (isOctaveMultiple i) = negate (octaves' i) - 1+  | isNegative i && isOctaveMultiple i       = negate (octaves' i)+  | otherwise                                = octaves' i++isOctaveMultiple (Interval (_,d)) = d `mod` 7 == 0++octaves' i = fromIntegral $ intervalDiv i basis_P8++-- | -- Returns the simple part of an interval. -- -- > (perfect octave)^*x + y = z  iff  y = simple z@@ -552,7 +642,7 @@ -- Returns whether the given interval is compound. -- -- A compound interval is either a negative interval, or a positive interval spanning--- more than octave.+-- one octave or more. -- isCompound :: Interval -> Bool isCompound x = octaves x /= 0@@ -561,19 +651,19 @@ -- Returns whether the given interval is negative. -- isNegative :: Interval -> Bool-isNegative x = octaves x < 0+isNegative (Interval (a, d)) = d < 0  -- | -- Returns whether the given interval is positive. -- isPositive :: Interval -> Bool-isPositive x = octaves x >= 0 && not (isPerfectUnison x)+isPositive x@(Interval (a, d)) = d >= 0 && not (isPerfectUnison x)  -- | -- Returns whether the given interval is non-negative. This implies that it is either positive or a perfect unison. -- isNonNegative :: Interval -> Bool-isNonNegative x = octaves x >= 0+isNonNegative (Interval (a, d)) = d >= 0  -- | -- Returns whether the given interval a perfect unison.@@ -589,7 +679,7 @@ -- semitones. -- isStep :: Interval -> Bool-isStep x = isSimple (abs x) && number (abs x) <= 2+isStep (Interval (a, d)) = (abs d) <= 2  -- | -- Returns whether the given interval is a leap (larger than a second).@@ -599,7 +689,7 @@ -- semitones. -- isLeap :: Interval -> Bool-isLeap x = isCompound (abs x) || number (abs x) > 2+isLeap (Interval (a, d)) = (abs d) > 2   -- |@@ -616,8 +706,13 @@ invert :: Interval -> Interval invert = simple . negate -+-- |+-- This is just the identity function, but is useful to fix the type of 'Interval'.+--+asInterval :: Interval -> Interval+asInterval = id +{- isPerfectNumber :: Int -> Bool isPerfectNumber 0 = True isPerfectNumber 1 = False@@ -626,19 +721,85 @@ isPerfectNumber 4 = True isPerfectNumber 5 = False isPerfectNumber 6 = False+-} +-- TODO more generic pattern here diatonicToChromatic :: Int -> Int-diatonicToChromatic = go+diatonicToChromatic d = (octaves*12) + go restDia     where-        go 0 = 0-        go 1 = 2-        go 2 = 4-        go 3 = 5-        go 4 = 7-        go 5 = 9-        go 6 = 11+        -- restDia is always in [0..6]+        (octaves, restDia) = d `divMod` 7+        go = ([0,2,4,5,7,9,11] !!) -{-# DEPRECATED intervalDiff "This should be hidden" #-}-{-# DEPRECATED mkInterval'  "This should be hidden "#-}+-- {-# DEPRECATED intervalDiff "This should be hidden" #-}+-- {-# DEPRECATED mkInterval'  "This should be hidden "#-}  replicate' n = replicate (fromIntegral n)+++++-- | Integer div of intervals: i / di = x, where x is an integer+intervalDiv :: Interval -> Interval -> Int+intervalDiv (Interval (a, d)) (Interval (1, 0)) = a+intervalDiv (Interval (a, d)) (Interval (0, 1)) = d+intervalDiv i di+  | (i > basis_P1) = intervalDivPos i di+  | (i < basis_P1) = intervalDivNeg i di+  | otherwise = 0 :: Int+  where +    intervalDivPos i di+      | (i < basis_P1) = undefined+      | (i ^-^ di) < basis_P1 = 0+      | otherwise = 1 + (intervalDiv (i ^-^ di) di)+    intervalDivNeg i di+      | (i > basis_P1) = undefined+      | (i ^+^ di) > basis_P1 = 0+      | otherwise = 1 + (intervalDiv (i ^+^ di) di)++-- | Represent an interval i in a new basis (j, k).+-- +-- We want x,y where i = x*j + y*k+--+-- e.g., convertBasis basis_d2 _P5 basis_P8 == Just (-12,7), as expected.++convertBasis+  :: Interval +  -> Interval +  -> Interval +  -> Maybe (Int, Int)+convertBasis i j k+  | (p == 0) = Nothing+  | not $ p `divides` r = Nothing+  | not $ p `divides` q = Nothing+  | otherwise = Just (r `div` p, q `div` p)+  where Interval (m, n) = i+        Interval (a, b) = j+        Interval (c, d) = k+        p = (a*d - b*c)+        q = (a*n - b*m)+        r = (d*m - c*n)+++-- | Same as above, but don't worry if new interval has non-integer+-- coefficients -- useful when getting a value to use as a frequency+-- ratio in a tuning system.+convertBasisFloat :: (Fractional t, Eq t)+  => Interval +  -> Interval +  -> Interval +  -> Maybe (t, t)+convertBasisFloat i j k+  | (p == 0) = Nothing+  | otherwise = Just (r / p, q / p)+  where Interval (m, n) = i+        Interval (a, b) = j+        Interval (c, d) = k+        p = fromIntegral $ (a*d - b*c)+        q = fromIntegral $ (a*n - b*m)+        r = fromIntegral $ (d*m - c*n)+++divides :: Integral a => a -> a -> Bool+x `divides` y = (y `rem` x) == 0+

@@ -4,7 +4,7 @@  ------------------------------------------------------------------------------------ -- |--- Copyright   : (c) Hans Hoglund 2012+-- Copyright   : (c) Hans Hoglund, Edward Lilley 2012–2014 -- -- License     : BSD-style --@@ -35,7 +35,9 @@         Name(..),          -- * Pitch-        Pitch,    +        Pitch,+        Pitch(..),+                 mkPitch,         name,         accidental,@@ -186,8 +188,16 @@ -- > d5  == diminished fifth == diminish (perfect fifth) -- newtype Pitch = Pitch { getPitch :: Interval }-    deriving (Eq, Num, Ord, Typeable)+    deriving (Eq, Ord, Typeable)     +instance Num Pitch where+    Pitch a + Pitch b = Pitch (a + b)+    negate (Pitch a)  = Pitch (negate a)+    abs (Pitch a)     = Pitch (abs a)+    (*)           = error  "Music.Pitch.Common.Pitch: no overloading for (*)"+    signum        = error "Music.Pitch.Common.Pitch: no overloading for signum"+    fromInteger   = error "Music.Pitch.Common.Pitch: no overloading for fromInteger"+ instance AffineSpace Pitch where     type Diff Pitch     = Interval     Pitch a .-. Pitch b = a ^-^ b@@ -209,8 +219,8 @@     flatten (Pitch a) = Pitch (diminish a)  instance Enum Pitch where-    toEnum = (c .+^) . perfect . fromIntegral-    fromEnum = fromIntegral . number . (.-. c)+    toEnum = Pitch . mkInterval' 0 . fromIntegral+    fromEnum = fromIntegral . pred . number . (.-. c)  -- | -- This is just the identity function, but is useful to fix the type of 'Pitch'.@@ -222,7 +232,7 @@ -- Creates a pitch from name accidental. -- mkPitch :: Name -> Accidental -> Pitch-mkPitch name acc = Pitch $ mkInterval' (fromIntegral acc) (fromEnum name + 1)+mkPitch name acc = Pitch $ mkInterval' (fromIntegral acc) (fromEnum name)  -- | -- Returns the name of a pitch.@@ -235,7 +245,12 @@ -- @ -- name :: Pitch -> Name-name = toEnum . fromIntegral . pred . number . simple . getPitch+name x               +  | i == 7           = toEnum 0 -- Arises for flat C etc.+  | 0 <= i && i <= 6 = toEnum i+  | otherwise        = error $ "Pitch.name: Bad value " ++ show i+  where+    i = (fromIntegral . pred . number . simple . getPitch) x  -- | -- Returns the accidental of a pitch.@@ -252,7 +267,7 @@  instance IsPitch Pitch where     fromPitch (PitchL (c, a, o)) =-        Pitch $ mkInterval' (qual a) (c + 1)+        Pitch $ mkInterval' (qual a) c             ^+^             (perfect octave^* fromIntegral o)         where

@@ -3,7 +3,7 @@  ------------------------------------------------------------------------------------ -- |--- Copyright   : (c) Hans Hoglund 2012+-- Copyright   : (c) Hans Hoglund, Edward Lilley 2012–2014 -- -- License     : BSD-style --@@ -11,7 +11,7 @@ -- Stability   : experimental -- Portability : non-portable (TF,GNTD) ----- Provides semitone, octave and step representaiton of intervals.+-- Provides semitone, octave and step representation of intervals. -- ------------------------------------------------------------------------------------- @@ -113,11 +113,14 @@ -- -- Intervals that name a number of semitones (i.e. 'semitone', 'tritone') does -- not have an unequivocal spelling. To convert these to an interval, a--- 'Spelling' must be provided as in:+-- 'Spelling' must be provided: ----- > spell sharps tritone == augmented fourth--- > spell flats  tritone == diminished fifth+-- >>> spell usingSharps tritone+-- _A4 --+-- >>> spell usingFlats  tritone+-- d5+-- newtype Semitones = Semitones { getSemitones :: Integer }     deriving (Eq, Ord, Num, Enum, Real, Integral) @@ -135,12 +138,14 @@     -- The number of semitones is negative if and only if the interval is     -- negative.     ---    -- Examples:-    ---    -- > semitones (perfect unison)  =  0-    -- > semitones tritone           =  6-    -- > semitones d5                =  6-    -- > semitones (-_P8)            =  -12+    -- >>> semitones (perfect unison)+    -- 0+    -- >>> semitones tritone+    -- 6+    -- >>> semitones d5+    -- 6+    -- >>> semitones (-_P8)+    -- -12     --     semitones :: a -> Semitones @@ -180,11 +185,21 @@ -- | -- Enharmonic equivalence. --+-- >>> asInterval _A2 == m3+-- False+-- >>> asInterval _A2 =:= m3+-- True+-- (=:=) :: HasSemitones a => a -> a -> Bool a =:= b = semitones a == semitones b  -- | -- Enharmonic non-equivalence.+--+-- >>> asInterval _A2 /= m3+-- True+-- >>> asInterval _A2 /:= m3+-- False -- (/:=) :: HasSemitones a => a -> a -> Bool a /:= b = semitones a /= semitones b

@@ -3,7 +3,7 @@  ------------------------------------------------------------------------------------ -- |--- Copyright   : (c) Hans Hoglund 2012+-- Copyright   : (c) Hans Hoglund, Edward Lilley 2012–2014 -- -- License     : BSD-style --@@ -85,7 +85,7 @@     (octaves, steps) = semitones x `divMod` 12     num  = fromIntegral (spelling steps)     diff = fromIntegral steps - fromIntegral (diatonicToChromatic num)-    in mkInterval' diff (num + 1) ^+^ _P8^*(fromIntegral octaves)+    in mkInterval' diff num ^+^ _P8^*(fromIntegral octaves)     where         diatonicToChromatic = go             where

@@ -0,0 +1,109 @@++{-# LANGUAGE RankNTypes #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Hans Hoglund 2012+--+-- License     : BSD-style+--+-- Maintainer  : hans@hanshoglund.se+-- Stability   : experimental+-- Portability : portable+--+-- Equal temperament pitch of any size.+--+-------------------------------------------------------------------------------------++module Music.Pitch.Equal (+    -- Equal,+    -- toEqual,+    -- Equal6,+    -- Equal12,+    -- Equal17,+    -- Equal24,+    -- Equal36,+    -- -- toEqual',+    -- unsafeToEqual,+    -- value,+    -- size,+    -- cast,+)+where++-- {-+-- +-- TODO mixing things up here+-- +--   This type implements limited values (useful for interval *steps*)+--   An ET-interval is just an int, with a type-level size (divMod is "separate")+-- +-- +-- -}+-- +-- +-- import Data.Maybe+-- import Data.Either+-- import Data.Semigroup+-- import Control.Monad+-- import Control.Applicative+-- import Music.Pitch.Absolute+-- +-- import Data.TypeLevel.Num hiding ((<), (>), (+), (<=), (*))+-- import qualified Data.TypeLevel.Num as TL+-- +-- data Foo = Foo Int deriving Show+-- +-- newtype Equal a = Equal { getEqual :: Pos a => Int }+--   deriving ()+-- +-- instance Pos a => Show (Equal a) where+--   -- show (Equal x) = "(Equal " ++ (show x) ++ ")"+--   showsPrec d (Equal x) = showParen (d > app_prec) $+--        showString "Equal " . showsPrec (app_prec+1) x+--     where app_prec = 10+-- +-- -- Convenience to avoid ScopedTypeVariables etc    +-- getSize :: Pos a => Equal a -> a+-- getSize = undefined+-- +-- -- | Value, which is in @[0,size x)@.+-- value :: Pos a => Equal a -> Int+-- value = getEqual+-- +-- -- | Size of this type (value not evaluated).+-- size :: Pos a => Equal a -> Int+-- size = toInt . getSize+-- +-- toEqual :: Pos a => Int -> Maybe (Equal a)+-- toEqual = toEqual' undefined+-- +-- toEqual' :: Pos a => a -> Int -> Maybe (Equal a)+-- toEqual' s n = if 0 <= n && n < toInt s then Just (Equal n) else Nothing+-- +-- unsafeToEqual :: Int -> Equal a+-- unsafeToEqual n = Equal n+-- +-- type Equal6  = Equal D6+-- type Equal12 = Equal D12+-- type Equal17 = Equal D17+-- type Equal24 = Equal D24+-- type Equal36 = Equal D36+-- +-- -- unsafemapValue :: (Int -> Int) -> Equal a -> Equal b+-- -- mapValue+-- +-- -- b = 24, a = 12, mul = 24/12+-- -- | Safely cast a tempered value to a larger size.+-- --+-- -- >>> cast (unsafeToEqual 1 :: Equal12) :: Equal24+-- -- Equal 2 :: Equal24+-- --+-- cast :: (Pos a, Pos b, Pos c, Div b a c) => Equal a -> Equal b+-- cast = cast' undefined+-- +-- cast' :: (Pos a, Pos b, Pos c, Div b a c) => Equal c -> Equal a -> Equal b+-- cast' cDummy (Equal a) = Equal (a * size cDummy)+-- +-- +-- 

@@ -13,24 +13,102 @@ -- ------------------------------------------------------------------------------------- -module Music.Pitch.Intonation -- (--- )+module Music.Pitch.Intonation (+      Intonation,+      Tuning,++      intone,+      -- makeBasis,+      synTune,+      tetTune,+      pureOctaveWith,++      -- * Specific tunings+      pythagorean,+      quarterCommaMeantone,+      schismaticMeantone,+      fiveToneEqual,+      sevenToneEqual,+      twelveToneEqual,+      nineteenToneEqual,+      thirtyOneToneEqual,+      fiftyThreeToneEqual,++      -- * Specific intonations+      -- standardTuning,+      standardIntonation,+) where  import Data.Maybe import Data.Either import Data.Semigroup+import Data.VectorSpace+import Data.AffineSpace import Control.Monad import Control.Applicative+ import Music.Pitch.Absolute+import Music.Pitch.Literal+import Music.Pitch.Common.Interval+import Music.Pitch.Common.Pitch -type Intonation a = a -> Hertz+type Intonation p = p -> Hertz+type Tuning i = i -> {-FreqRatio-}Hertz -pure :: Integral a => Intonation a-pure = undefined+synTune :: (Interval, {-FreqRatio-}Hertz) -> (Interval, {-FreqRatio-}Hertz) -> Interval -> {-FreqRatio-}Hertz+synTune (i1, i1rat) (i2, i2rat) (Interval (a1, d2)) =+  ((makeA1 (i1, i1rat) (i2, i2rat)) ^* (fromIntegral a1)) ^+^ ((maked2 (i1, i1rat) (i2, i2rat)) ^* (fromIntegral d2))+  where makeA1 = makeBasis basis_A1+        maked2 = makeBasis basis_d2 -pythagorean :: Integral a => Intonation a-pythagorean = undefined+makeBasis :: Interval -> (Interval, {-FreqRatio-}Hertz) -> (Interval, {-FreqRatio-}Hertz) -> {-FreqRatio-}Hertz+makeBasis i (i1, r1) (i2, r2) = case (convertBasisFloat i i1 i2) of+  Just (x, y) -> (x *^ r1) ^+^ (y *^ r2)+  Nothing -> error ("Cannot use intervals " ++ (show i1) ++ " and " ++ (show i2) ++ " as basis pair to represent " ++ (show i)) -twelveToneEqual :: Integral a => Intonation a-twelveToneEqual = undefined+-- | Turn a tuning into an intonation.+intone :: (Pitch, Hertz) -> Tuning Interval -> Intonation Pitch+intone (b, f) t p = f .+^ (t i) where i = p .-. b+-- More generally:+-- intone :: AffineSpace p => (p, Hertz) -> Tuning (Diff p) -> Intonation p+++-- Standard syntonic (meantone) tunings, with P8 = 2++pureOctaveWith = synTune (_P8, 2)++pythagorean :: Tuning Interval+pythagorean = pureOctaveWith (_P5, 3/2)++quarterCommaMeantone :: Tuning Interval+quarterCommaMeantone = pureOctaveWith (_M3, 5/4)++schismaticMeantone :: Tuning Interval+schismaticMeantone = pureOctaveWith (8 *^ _P4, 10)++-- TET tunings, i.e. where P8 = 2 and (some other interval) = 1++tetTune i = pureOctaveWith (i, 1)++fiveToneEqual :: Tuning Interval+fiveToneEqual = tetTune m2++sevenToneEqual :: Tuning Interval+sevenToneEqual = tetTune _A1++twelveToneEqual :: Tuning Interval+twelveToneEqual = tetTune d2++nineteenToneEqual :: Tuning Interval+nineteenToneEqual = tetTune dd2 where dd2 = d2 ^-^ _A1++thirtyOneToneEqual :: Tuning Interval+thirtyOneToneEqual = tetTune dddd3 where dddd3 = m3 ^-^ (4 *^ _A1)++fiftyThreeToneEqual :: Tuning Interval+fiftyThreeToneEqual = tetTune ddddddd6 where ddddddd6 = 31 *^ _P8 ^-^ 53 *^ _P5 -- (!)++-- | Modern standard intonation, i.e. 12-TET with @a = 440 Hz@.+standardIntonation :: Intonation Pitch+standardIntonation = intone (a, 440) twelveToneEqual

@@ -0,0 +1,65 @@++{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveFoldable             #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeFamilies               #-}++module Music.Pitch.StaffLines (+        StaffLines,+        HalfSpaces,+  ) where++import Numeric.Natural+import Data.Typeable++-- TODO maybe parameterize stafflines on number of staves++-- |+-- For notation systems using staff lines (i.e. CMN), this type represents staff number.+--+-- Rules:+--+-- * Incrementing staff lines means moving upward.--+--+-- * For staff systems with an odd number of lines, 0 is the middle staff.+--+-- * For staff systems with an even number of lines, 0 is the staff below the middle space.+--+-- I.e. in CMN the staff lines are @[-2..2]@, with negative numbers representing the lines+-- below the middle line and positions numbers representing the lines above it.+--+newtype StaffLines = StaffLines { getStaffLines :: Integer }+  deriving (Eq, Ord, Read, Show, Enum,+           Num, Real, Integral, Typeable)++-- |+-- For notation systems using staff lines, this type represents the difference betwee two+-- staff positions (i.e. one diatonic step in CMN).+--+-- Rules:+--+-- * Incrementing half spaces means moving upward.+--+-- * For staff systems with an odd number of lines, 0 is the middle staff.+--+-- * For staff systems with an even number of lines, 0 is the middle space.+--+-- I.e. in CMN, the non-ledger positions are @[-5..5]@ with the even numbers representing+-- lines and the odd representing spaces and with positive numbers representing positions+-- above the middle line and negative numbers representing positions below.+--+newtype HalfSpaces = HalfSpaces { getHalfSpaces :: Integer }+  deriving (Eq, Ord, Read, Show, Enum,+           Num, Real, Integral, Typeable)+++-- staffLinesForNumber :: Int -> StaffLines+-- staffLinesForNumber