diff --git a/music-pitch.cabal b/music-pitch.cabal --- a/music-pitch.cabal +++ b/music-pitch.cabal @@ -1,6 +1,6 @@ name: music-pitch -version: 1.8 +version: 1.8.1 cabal-version: >= 1.10 author: Hans Hoglund maintainer: Hans Hoglund @@ -26,7 +26,7 @@ containers, lens >= 4.6 && < 4.7, semigroups >= 0.13.0.1 && < 1, - music-pitch-literal == 1.8, + music-pitch-literal == 1.8.1, data-interval >= 1.0.0 && < 2, vector-space >= 0.8.7 && < 0.9, vector-space-points >= 0.2 && < 0.3, @@ -48,10 +48,11 @@ Music.Pitch.Common.Harmony Music.Pitch.Common.Names Music.Pitch.Ambitus - Music.Pitch.StaffLines + Music.Pitch.Scale Music.Pitch.Clef - Music.Pitch.Tokawa Music.Pitch.Intonation + other-modules: Music.Pitch.StaffLines + Music.Pitch.Tokawa hs-source-dirs: src default-language: Haskell2010 ghc-options: -fno-warn-typed-holes diff --git a/src/Music/Pitch/Ambitus.hs b/src/Music/Pitch/Ambitus.hs --- a/src/Music/Pitch/Ambitus.hs +++ b/src/Music/Pitch/Ambitus.hs @@ -16,11 +16,21 @@ -- ------------------------------------------------------------------------------------- -module Music.Pitch.Ambitus where +module Music.Pitch.Ambitus ( + Ambitus, + ambitus, + ambitus', + mapAmbitus, + ambitusHighest, + ambitusLowest, + ambitusInterval, + ) where import Data.Interval hiding (Interval, interval) import qualified Data.Interval as I import Control.Lens +import Data.VectorSpace +import Data.AffineSpace -- | An ambitus is a closed interval (in the mathematical sense). -- @@ -39,11 +49,27 @@ instance (Show a, Num a, Ord a) => Show (Ambitus a) where show a = show (a^.from ambitus) ++ "^.ambitus" -ambitus :: (Num a, Ord a) => Iso' (a, a) (Ambitus a) +ambitus :: (Num a, Ord a) => Iso (a, a) (b, b) (Ambitus a) (Ambitus b) ambitus = iso toA unA . _Unwrapped where toA = (\(m, n) -> (I.<=..<=) (Finite m) (Finite n)) unA a = case (I.lowerBound a, I.upperBound a) of (Finite m, Finite n) -> (m, n) +ambitus' :: (Num a, Ord a) => Iso' (a, a) (Ambitus a) +ambitus' = ambitus + +-- | Not a true functor for similar reasons as sets. +mapAmbitus :: (Ord b, Num b) => (a -> b) -> Ambitus a -> Ambitus b +mapAmbitus = over (from ambitus . both) + +-- | Returns a postive interval (or _P1 for empty ambitus) +ambitusInterval :: (Num a, Ord a, AffineSpace a) => Ambitus a -> Diff a +ambitusInterval x = let (m,n) = x^.from ambitus in n .-. m + +ambitusLowest :: (Num a, Ord a) => Ambitus a -> a +ambitusLowest x = let (m,n) = x^.from ambitus in m + +ambitusHighest :: (Num a, Ord a) => Ambitus a -> a +ambitusHighest x = let (m,n) = x^.from ambitus in n diff --git a/src/Music/Pitch/Common/Chromatic.hs b/src/Music/Pitch/Common/Chromatic.hs --- a/src/Music/Pitch/Common/Chromatic.hs +++ b/src/Music/Pitch/Common/Chromatic.hs @@ -5,7 +5,9 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} -module Music.Pitch.Common.Chromatic where +module Music.Pitch.Common.Chromatic ( + ChromaticSteps, + ) where newtype ChromaticSteps = ChromaticSteps { getChromaticSteps :: Integer } diff --git a/src/Music/Pitch/Common/Diatonic.hs b/src/Music/Pitch/Common/Diatonic.hs --- a/src/Music/Pitch/Common/Diatonic.hs +++ b/src/Music/Pitch/Common/Diatonic.hs @@ -5,7 +5,9 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} -module Music.Pitch.Common.Diatonic where +module Music.Pitch.Common.Diatonic ( + DiatonicSteps, + ) where newtype DiatonicSteps = DiatonicSteps { getDiatonicSteps :: Integer } deriving (Eq, Ord, Show, Enum, Num, Real, Integral) diff --git a/src/Music/Pitch/Common/Interval.hs b/src/Music/Pitch/Common/Interval.hs --- a/src/Music/Pitch/Common/Interval.hs +++ b/src/Music/Pitch/Common/Interval.hs @@ -427,7 +427,7 @@ -- semitones. -- isStep :: Interval -> Bool -isStep (Interval (a, d)) = (abs d) <= 2 +isStep (Interval (a, d)) = (abs d) <= 1 -- | -- Returns whether the given interval is a leap (larger than a second). @@ -437,7 +437,7 @@ -- semitones. -- isLeap :: Interval -> Bool -isLeap (Interval (a, d)) = (abs d) > 2 +isLeap (Interval (a, d)) = (abs d) > 1 -- | diff --git a/src/Music/Pitch/Common/Quality.hs b/src/Music/Pitch/Common/Quality.hs --- a/src/Music/Pitch/Common/Quality.hs +++ b/src/Music/Pitch/Common/Quality.hs @@ -5,24 +5,25 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} -module Music.Pitch.Common.Quality where -{- --- * Quality -Quality(..), -HasQuality(..), -invertQuality, -isPerfect, -isMajor, -isMinor, -isAugmented, -isDiminished, +module Music.Pitch.Common.Quality ( + -- * Quality + Quality(..), + HasQuality(..), + invertQuality, + isPerfect, + isMajor, + isMinor, + isAugmented, + isDiminished, -QualityType(..), -expectedQualityType, -qualityTypes, -qualityToDiff, + -- * Quality type + QualityType(..), + expectedQualityType, + qualityTypes, + qualityToDiff --} +) where + import Music.Pitch.Augmentable import Music.Pitch.Common.Number import Music.Pitch.Common.Chromatic diff --git a/src/Music/Pitch/Scale.hs b/src/Music/Pitch/Scale.hs new file mode 100644 --- /dev/null +++ b/src/Music/Pitch/Scale.hs @@ -0,0 +1,188 @@ + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + +------------------------------------------------------------------------------------ +-- | +-- Copyright : (c) Hans Hoglund, Edward Lilley 2012–2014 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +------------------------------------------------------------------------------------- + +module Music.Pitch.Scale ( + Mode, + Scale, + majorScale, + pureMinorScale, + harmonicMinorScale, + melodicMinorScale, + aeolian, + locrian, + ionian, + dorian, + phrygian, + lydian, + mixolydian, + majorPentaTonic, + minorPentaTonic, + bluesScale, + bebopScale, + wholeTone, + octatonic, + firstMode, + secondMode, + thirdMode, + fourthMode, + fifthMode, + sixthMode, + seventhMode, + + Function, + _intervals, + _repeat, + Chord, + _tonic, + + majorTriad, + minorTriad, + augmentedChord, + diminishedChord, + halfDiminishedChord, + majorSeventhChord, + + ) where + +import Data.VectorSpace +import Data.AffineSpace +import Music.Pitch.Literal +import Control.Lens +import Music.Pitch hiding (Mode) -- Test + +data Mode a = Mode [Diff a] (Diff a) -- intervals, repeat (usually octave) +data Scale a = Scale a (Mode a) -- root, mode + +data Function a = Function [Diff a] (Diff a) -- intervals, repeat, repeat (usually octave) +data Chord a = Chord a (Function a) -- root, function + +_intervals :: Lens' (Function a) [Diff a] +_intervals f (Function is r) = fmap (\is -> Function is r) $ f is + +_repeat :: Lens' (Function a) (Diff a) +_repeat f (Function is r) = fmap (\r -> Function is r) $ f r + +{- +_pitches :: Lens' (Chord a) [a] +_pitches f (Chord t xs) = fmap (\xs -> Chord t (fmap (.-. t) xs)) $ f (fmap (.+^ t) $ xs) . _intervals +-} + +_tonic :: Lens' (Chord a) a +_tonic f (Chord t xs) = fmap (\t -> Chord t xs) $ f t + +majorScale :: Mode Pitch +majorScale = Mode [_M2,_M2] _P8 + +pureMinorScale :: Mode Pitch +pureMinorScale = undefined + +harmonicMinorScale :: Mode Pitch +harmonicMinorScale = undefined + +melodicMinorScale :: Mode Pitch +melodicMinorScale = undefined + +aeolian :: Mode Pitch +aeolian = Mode [_M2,_M2,m2,_M2,_M2,m2,_M2] _P8 + +locrian :: Mode Pitch +locrian = undefined + +ionian :: Mode Pitch +ionian = undefined + +dorian :: Mode Pitch +dorian = undefined + +phrygian :: Mode Pitch +phrygian = undefined + +lydian :: Mode Pitch +lydian = undefined + +mixolydian :: Mode Pitch +mixolydian = undefined + +majorPentaTonic :: Mode Pitch +majorPentaTonic = undefined + +minorPentaTonic :: Mode Pitch +minorPentaTonic = undefined + +bluesScale :: Mode Pitch +bluesScale = undefined + +bebopScale :: Mode Pitch +bebopScale = undefined + +wholeTone :: Mode Pitch +wholeTone = undefined + +octatonic :: Mode Pitch +octatonic = undefined + +firstMode :: Mode Pitch +firstMode = undefined + +secondMode :: Mode Pitch +secondMode = undefined + +thirdMode :: Mode Pitch +thirdMode = undefined + +fourthMode :: Mode Pitch +fourthMode = undefined + +fifthMode :: Mode Pitch +fifthMode = undefined + +sixthMode :: Mode Pitch +sixthMode = undefined + +seventhMode :: Mode Pitch +seventhMode = undefined + + + + +majorTriad :: Function Pitch +majorTriad = undefined + +minorTriad :: Function Pitch +minorTriad = undefined + +augmentedChord :: Function Pitch +augmentedChord = undefined + +diminishedChord :: Function Pitch +diminishedChord = undefined + +halfDiminishedChord :: Function Pitch +halfDiminishedChord = undefined + +majorSeventhChord :: Function Pitch +majorSeventhChord = undefined + + + + + +