Housekeeping

src/Base/Chord/Chord.hs

@@ -39,7 +39,7 @@ import Base.Core.Interval
 import Common.Utils (uncurry4, uncurry5)
 
 import Data.Function (on)
-import Data.List (sortBy, zip4, zip5)
+import Data.List (sortBy, zip4, zip5, intercalate)
 import qualified Data.List as L
 import Data.Map as M
 import Data.Maybe (catMaybes, fromJust)
@@ -48,7 +48,11 @@ import Data.Maybe (catMaybes, fromJust)
 -- but with the specific notes as well.
 data Chord = Chord { getSymbol :: ChordSymbol
                    , getNotes :: [Note]
-                   } deriving (Eq, Show)
+                   } deriving (Eq)
+
+instance Show Chord where
+  show c = show (getSymbol c) ++ ", [" ++ intercalate ", " (show <$> getNotes c) ++ "]"
+
 
 -- | A Chord has all the properties of the Chordal typeclass
 instance Chordal Chord where

src/Base/Chord/Diatonic.hs

@@ -82,7 +82,7 @@ diatonicChord scale@(Scale note mode) numNotes degree jumpSize =
 -- | Given a degree, returns a function that creates a diatonic triadic major chord
 -- from a key (i.e. a Note) and the number of notes.
 getMajorFuncChord :: Int -> Note -> Int -> Maybe Chord
-getMajorFuncChord deg key numNotes = diatonicChord (Scale key (modeFrom Ionian [])) numNotes deg 2
+getMajorFuncChord deg key numNotes = diatonicChord (Scale key (fromJust (modeFrom Ionian []))) numNotes deg 2
 
 -- | Given a key and a number of notes, this returns a triadic I chord.
 -- If number of notes is not between 2 and 7, this returns Nothing.

src/Base/Chord/Shape.hs

@@ -26,13 +26,19 @@ import Base.Class.Chordal
 import Base.Scale.Heliotonic
 
 import Data.Set hiding (foldr)
+import Data.List(intercalate)
 
 -- | A ChordShape, e.g. a M7 chord, is a rootless abstract shape.
 data ChordShape = ChordShape { getQuality :: Quality
                              , getHighestNatural :: HighestNatural
                              , getExtensions :: [Extension]
                              , getSus :: Sus
-                             } deriving (Eq, Show)
+                             } deriving (Eq)
+
+instance Show ChordShape where
+  show c = show (getQuality c) ++ show (getHighestNatural c)
+        ++ intercalate "" (show <$> getExtensions c) ++ show (getSus c)
+
 
 -- | ChordShape has all the properties of the Chordal typeclass
 instance Chordal ChordShape where

src/Base/Chord/Subs.hs

@@ -53,12 +53,11 @@ import Language.Parser
 -- | Removes the P5 interval from a given chord's note if it exists
 -- and returns the same chord symbol.
 --
--- prop> remove5 (chord, _) == chord
+-- prop> getSymbol $ remove5 chord == getSymbol chord
 --
 -- >>> c = canonicalizeChord $ fromJust $ parseChord "CM7"
--- >>> notes = chordToNotes c
--- >>> remove5 (c, notes)
--- (CM7,[C,E,B])
+-- >>> remove5 (chordFromSymbol c)
+-- CM7, [C, E, B]
 remove5 :: Chord -> Chord
 remove5 chord = updateNotes chord $ toNotes (root chord) $ S.delete (fromJust(intervalFrom Perfect 5)) (toIntervals chord)
   where
@@ -118,33 +117,35 @@ negative key chord = head $ notesToChord newNotes
 -- this transposes the chord by that interval. Because this function
 -- is only used internally by the module, it assumes the intervals are
 -- validly constructed.
--- TODO: Make this a safe, general-purpose, exportable function
-transposeChord :: Chord -> IQ.Quality -> Int -> Chord
-transposeChord chord iQual i =
+transposeChord :: Chord -> Interval -> Chord
+transposeChord chord interval =
   let
-    newChord = transposeToRoot (getSymbol chord )$ respell $ jumpIntervalFromNote (fromJust (intervalFrom iQual i)) $ root chord
+    newChord = transposeToRoot (getSymbol chord )$ respell $ jumpIntervalFromNote interval $ root chord
   in
     chordFromSymbol newChord
 
 -- | Given a dominant chord or a minor 6 chord, this returns
 -- a list of chord substitutions from its diminished family.
 --
 -- >>> c = canonicalizeChord $ fromJust $ parseChord "C7"
--- >>> notes = chordToNotes c
--- >>> dimFamilySub (c, notes)
--- [(Eb7,[Eb,G,Bb,Db]),(Gb7,[Gb,Bb,Db,Fb]),(A7,[A,C#,E,G])]
+-- >>> dimFamilySub (chordFromSymbol c)
+-- [Chord {getSymbol = ChordSymbol {getChordRoot = Eb, getShape = ChordShape {getQuality = , getHighestNatural = 7, getExtensions = [], getSus = }}, getNotes = [Eb,G,Bb,Db]},Chord {getSymbol = ChordSymbol {getChordRoot = Gb, getShape = ChordShape {getQuality = , getHighestNatural = 7, getExtensions = [], getSus = }}, getNotes = [Gb,Bb,Db,Fb]},Chord {getSymbol = ChordSymbol {getChordRoot = A, getShape = ChordShape {getQuality = , getHighestNatural = 7, getExtensions = [], getSus = }}, getNotes = [A,C#,E,G]}]
 dimFamilySub :: Chord -> [Chord]
 dimFamilySub eChord
   |  quality eChord == CQ.Dominant ||
     (quality eChord == CQ.Minor && (fromJust (intervalFrom IQ.Major 6) `member` toIntervals eChord))
-    = [transposeChord eChord IQ.Minor 3, transposeChord eChord (IQ.Diminished 1) 5, transposeChord eChord IQ.Major 6]
+    = [transposeBy IQ.Minor 3, transposeBy (IQ.Diminished 1) 5, transposeBy IQ.Major 6]
   | otherwise = []
+  where
+    transposeBy :: IQ.Quality -> Int -> Chord
+    transposeBy iQual i = transposeChord eChord $ fromJust $ intervalFrom iQual i
+
 
 -- | Returns the same chord, but a tritone away.
 -- If applied twice in a row, returns the same chord:
 -- prop> tritoneSub $ tritoneSub (chord, notes) == (_, notes)
 tritoneSub :: Chord -> Chord
-tritoneSub eChord = transposeChord eChord (IQ.Augmented 1) 4
+tritoneSub eChord = transposeChord eChord $ fromJust $ intervalFrom (IQ.Augmented 1) 4
 
 -- | Given a key, and a chord in the key, this returns
 -- a list of chords that are diatonic functional substitutes.

src/Base/Chord/Symbol.hs

@@ -36,7 +36,11 @@ import Data.Set
 -- a C and a M7 gives us a CM7.
 data ChordSymbol = ChordSymbol { getChordRoot :: Note
                                , getShape :: ChordShape
-                               } deriving (Eq, Show)
+                               } deriving (Eq)
+
+instance Show ChordSymbol where
+  show c = show (getChordRoot c) ++ show (getShape c)
+
 
 -- | ChordSymbol has all the properties of the Chordal typeclass,
 -- most importantly, that it can be converted to a set of intervals.

src/Base/Core/Interval.hs

@@ -44,7 +44,7 @@ import Common.Utils (modByFrom)
 
 import Control.Monad (zipWithM)
 
-import Data.Maybe (fromJust)
+import Data.Maybe (fromJust, isJust, fromMaybe)
 import Data.Set as S hiding (filter)
 
 -- | Intervals are defined by a quality and a size.
@@ -74,8 +74,6 @@ normalizeIntervalSize = modByFrom 7 1
 -- TODO: This should probably return an Either String Interval (or an error
 -- type in place of String) instead of Maybe Interval, in order to facilitate
 -- more sophisticated error handling / reporting.
---
--- TODO: Make sure diminished and augmented don't get arguments > 11
 intervalFrom :: Quality -> Int -> Maybe Interval
 intervalFrom q s = if normalizedSize `elem` goodSizes then
                      Just Interval { getQuality = q, getSize = normalizedSize }
@@ -161,23 +159,23 @@ instance Invertible Interval where
 -- the interval's distance is increased by that integer without
 -- changing its size.
 --
--- TODO: Figure out what to do if dim and aug < 11 and this function
--- receives an integer argument > 11.
---
 -- prop> intervalToDistance i + x == intervalToDistance (i <+> x)
 -- prop> getSize (i <+> _) == getSize i
 infixl 6 <+>
 (<+>) :: Interval -> Int -> Interval
-Interval iQual i <+> x =
-  Interval (iterate modFunc iQual !! abs x) i
+Interval iQual i <+> x = Interval (iterate smartMod iQual !! abs x) i
   where
+    unwrapMaybeQ :: (Maybe Quality -> Maybe Quality) -> Quality -> Quality
+    unwrapMaybeQ f qual = fromMaybe (baseQuality i) (f $ Just qual)
     modFunc =
       case (baseQuality i, signum x) of
         (Perfect, 1)  -> raisePerfect
         (Major, 1)    -> raiseMajor
         (Perfect, -1) -> lowerPerfect
         (Major, -1)   -> lowerMajor
         (_, 0)         -> id
+    smartMod = unwrapMaybeQ modFunc
+    newQual = iterate smartMod iQual !! abs x
 
 -- | When subtracting an integer from an interval with this infix operator,
 -- the interval's distance is decreased by that integer without
@@ -252,7 +250,5 @@ nthDegreeIntervals ints n = S.map (|-| noteInterval) ints
   where
    noteInterval = toAscList ints !! (n - 1)
 
-zipToIntervalSet :: [Quality] -> [Int] -> Maybe (Set Interval)
-zipToIntervalSet quals sizes =
-  do ints <- zipWithM intervalFrom quals sizes
-     return $ fromList ints
+zipToIntervalSet :: [Quality] -> [Int] -> Set Interval
+zipToIntervalSet quals sizes = fromList (fromJust . uncurry intervalFrom <$> zip quals sizes)

src/Base/Core/Quality/IQuality.hs

@@ -12,6 +12,7 @@ function to get the base quality of an interval size.
 -}
 module Base.Core.Quality.IQuality
   ( Quality(..)
+  , iQualFrom
   , baseQuality
   , raisePerfect
   , raiseMajor
@@ -27,9 +28,6 @@ import Common.Utils (modByFrom)
 3. Minor
 4. Diminished (single, doubly, triply, etc.)
 5. Augmented (single, doubly, triply, etc.)
-
-TODO: Make sure that interval qualities are using smart constructors
-so that diminished and augmented only receive integers >= 1.
 -}
 data Quality
  = Major
@@ -48,6 +46,14 @@ instance Show Quality where
   show (Diminished i) = if i == 1 then "dim" else show i ++ "dim"
   show (Augmented i)  = if i == 1 then "aug" else show i ++ "aug"
 
+
+iQualFrom :: Quality -> Maybe Quality
+iQualFrom (Diminished x) = if x > 0 && x < 12 then Just (Diminished x)
+                           else Nothing
+iQualFrom (Augmented x) = if x > 0 && x < 12 then Just (Augmented x)
+                           else Nothing
+iQualFrom q = Just q
+
 -- | Given an interval size, we return the base quality, either Perfect or Major
 baseQuality :: Int -> Quality
 baseQuality n
@@ -58,34 +64,38 @@ baseQuality n
 
 -- | Given an interval quality, this raises that quality by a semitone
 -- assuming that its base quality is Perfect.
-raisePerfect :: Quality -> Quality
-raisePerfect Perfect = Augmented 1
-raisePerfect (Augmented x)  = Augmented $ x + 1
-raisePerfect (Diminished 1) = Perfect
-raisePerfect (Diminished x) = Diminished $ x - 1
+raisePerfect :: Maybe Quality -> Maybe Quality
+raisePerfect (Just Perfect)        = Just $ Augmented 1
+raisePerfect (Just (Augmented x))  = iQualFrom $ Augmented $ x + 1
+raisePerfect (Just (Diminished 1)) = Just Perfect
+raisePerfect (Just (Diminished x)) = iQualFrom $ Diminished $ x - 1
+raisePerfect Nothing               = Nothing
 
 -- | Given an interval quality, this raises that quality by a semitone
 -- assuming that its base quality is Major.
-raiseMajor :: Quality -> Quality
-raiseMajor Major = Augmented 1
-raiseMajor (Augmented x)  = Augmented $ x + 1
-raiseMajor Minor          = Major
-raiseMajor (Diminished 1) = Minor
-raiseMajor (Diminished x) = Diminished $ x - 1
+raiseMajor :: Maybe Quality -> Maybe Quality
+raiseMajor (Just Major)          = Just $ Augmented 1
+raiseMajor (Just (Augmented x))  = iQualFrom $ Augmented $ x + 1
+raiseMajor (Just Minor        )  = Just Major
+raiseMajor (Just (Diminished 1)) = Just Minor
+raiseMajor (Just (Diminished x)) = iQualFrom $ Diminished $ x - 1
+raiseMajor Nothing               = Nothing
 
 -- | Given an interval quality, this lowers that quality by a semitone
 -- assuming that its base quality is Perfect.
-lowerPerfect :: Quality -> Quality
-lowerPerfect Perfect        = Diminished 1
-lowerPerfect (Diminished x) = Diminished $ x + 1
-lowerPerfect (Augmented 1)  = Perfect
-lowerPerfect (Augmented x)  = Augmented $ x-1
+lowerPerfect :: Maybe Quality -> Maybe Quality
+lowerPerfect (Just Perfect)        = Just $ Diminished 1
+lowerPerfect (Just (Diminished x)) = iQualFrom $ Diminished $ x + 1
+lowerPerfect (Just (Augmented 1))  = Just Perfect
+lowerPerfect (Just (Augmented x))  = iQualFrom $ Augmented $ x-1
+lowerPerfect Nothing               = Nothing
 
 -- | Given an interval quality, this lowers that quality by a semitone
 -- assuming that its base quality is Major.
-lowerMajor :: Quality -> Quality
-lowerMajor Major          = Minor
-lowerMajor Minor          = Diminished 1
-lowerMajor (Diminished x) = Diminished $ x + 1
-lowerMajor (Augmented 1)  = Major
-lowerMajor (Augmented x)  = Augmented $ x - 1
+lowerMajor :: Maybe Quality -> Maybe Quality
+lowerMajor (Just Major)          = Just Minor
+lowerMajor (Just Minor)          = Just $ Diminished 1
+lowerMajor (Just (Diminished x)) = iQualFrom $ Diminished $ x + 1
+lowerMajor (Just (Augmented 1))  = Just Major
+lowerMajor (Just (Augmented x))  = iQualFrom $ Augmented $ x - 1
+lowerMajor Nothing               = Nothing

src/Base/Scale/BaseMode.hs

@@ -19,11 +19,10 @@ import Base.Core.Interval
 import Base.Core.Quality.IQuality
 
 import Data.Maybe (fromJust)
-import Data.Set
+import Data.Set hiding (filter)
+import qualified Data.Set as S(filter)
 
 -- | A BaseMode must be one of these names.
--- TODO: Implement: Blues scale, pentatonics
--- TODO: Figure out if we're missing any more.
 data BaseMode
   = Lydian
   | Dorian
@@ -43,19 +42,26 @@ data BaseMode
   | DoubleHarmonicMinor
   | HarmonicMajor
   | DoubleHarmonicMajor
+  | Blues
+  | MajorPentatonic
+  | MinorPentatonic
+  | Bebop
+  | WholeTone
+  | Hirajoshi
+  | HalfWhole
+  | WholeHalf
   deriving (Show, Enum, Eq)
 
 -- | Given a base mode, this returns a set of intervals. Whereas
 -- some base modes are created from scratch (like Ionian), others
 -- (e.g. Dorian, Phrygian, etc.) can be derived by shifting those modes.
 baseModeIntervals :: BaseMode -> Set Interval
-baseModeIntervals bm = if fromScratch then
-                         fromJust $ zipToIntervalSet bmQualities [1 .. 7]
-                       else
-                         let
-                           (mode, shift) = modeAndShift
-                         in
-                           nthDegreeIntervals (baseModeIntervals mode) shift
+baseModeIntervals bm
+  | fromScratch = zipToIntervalSet bmQualities [1 .. 7]
+  | nonHeptatonic = nonHepInts
+  | otherwise
+  = let (mode, shift) = modeAndShift
+    in nthDegreeIntervals (baseModeIntervals mode) shift
   where
     -- Discriminate between BaseModes for which we build the intervals from
     -- scratch and those that are computed from some other interval set
@@ -70,6 +76,19 @@ baseModeIntervals bm = if fromScratch then
                             , DoubleHarmonicMajor
                             ]
 
+    -- Discriminate between BaseModes that have scale degrees 1-7 and those
+    -- that do not.
+    nonHeptatonic :: Bool
+    nonHeptatonic = bm `elem` [ Blues
+                              , MajorPentatonic
+                              , MinorPentatonic
+                              , Bebop
+                              , WholeTone
+                              , Hirajoshi
+                              , HalfWhole
+                              , WholeHalf
+                              ]
+
     -- The interval qualities for the modal interval sets built from scratch
     bmQualities :: [Quality]
     bmQualities =
@@ -91,6 +110,37 @@ baseModeIntervals bm = if fromScratch then
         DoubleHarmonicMajor ->
           [Perfect, Minor, Major, Perfect, Perfect, Minor, Major]
 
+    -- The interval sets for the non-heptatonic modes
+    nonHepInts :: Set Interval
+    nonHepInts = zipToIntervalSet quals iSizes
+      where
+        (quals, iSizes) =
+          case bm of
+            Blues ->
+              ([Perfect, Minor, Perfect, Diminished 1, Perfect, Minor],
+               [1, 3, 4, 5, 5, 7])
+            MajorPentatonic ->
+              ([Perfect, Major, Major, Perfect, Major],
+               [1, 2, 3, 5, 6])
+            MinorPentatonic ->
+              ([Perfect, Minor, Perfect, Perfect, Minor],
+               [1, 3, 4, 5, 7])
+            Bebop ->
+              ([Perfect, Major, Major, Perfect, Perfect, Major, Minor, Major],
+               [1, 2, 3, 4, 5, 6, 7, 7])
+            WholeTone ->
+              ([Perfect, Major, Major, Diminished 1, Minor, Minor],
+               [1, 2, 3, 5, 6, 7])
+            Hirajoshi ->
+              ([Perfect, Major, Minor, Perfect, Minor],
+               [1, 2, 3, 5, 6])
+            HalfWhole ->
+              ([Perfect, Minor, Minor, Major, Augmented 1, Perfect, Major, Minor],
+               [1, 2, 3, 3, 4, 5, 6, 7])
+            WholeHalf ->
+              ([Perfect, Major, Minor, Perfect, Diminished 1, Minor, Major, Major],
+               [1, 2, 3, 4, 5, 6, 6, 7])
+
     -- The starting mode and shift for modal interval sets built from other
     -- interval sets
     modeAndShift :: (BaseMode, Int)
@@ -106,3 +156,4 @@ baseModeIntervals bm = if fromScratch then
         LydianDom   -> (MelodicMinor, 4)
         Altered     -> (MelodicMinor, 7)
         PhrygianDom -> (HarmonicMinor, 5)
+

src/Base/Scale/Extension.hs

@@ -29,6 +29,5 @@ instance Show Extension where
   show ext = show (getAccidental ext) ++ show (getDegree ext)
 
 -- | Smart constructor for a scale extension.
--- TODO: Figure out whether this should exclude the AccNatural possibility
 scaleExtensionFrom :: Accidental -> Int -> Extension
 scaleExtensionFrom = Extension