module Music.Instrument.Guitar where
import Music.Diatonic
import Music.Diatonic.Note
import Music.Diatonic.Degree
import Music.Diatonic.Chord
import Music.Diatonic.Scale
import Data.List
import Data.Maybe
import Data.Char
import Control.Monad
import qualified Data.Set
import Music.Instrument.Piano
import Music.Instrument.Common
import Debug.Trace
class PositionPatternProgression a where
getPositionPatternProgressions :: Bool -> a -> [Note] -> Int -> [[[[Int]]]]
requiresSequence :: a -> Bool
instance PositionPatternProgression Chord where
getPositionPatternProgressions allowOpens chord tuning maxHeight = filter (not . null) $ findPositionPatterns allowOpens chord tuning maxHeight
requiresSequence _ = True
instance PositionPatternProgression Scale where
getPositionPatternProgressions allowOpens scale tuning maxHeight = filter (not . null) $ findPositionPatterns allowOpens scale tuning maxHeight
requiresSequence _ = False
instance PositionPatternProgression Note where
getPositionPatternProgressions allowOpens note tuning maxHeight = filter (not . null) $ findPositionPatterns allowOpens note tuning maxHeight
requiresSequence _ = False
findPositionPatterns allowOpens chord tuning maxHeight =
filter (not . null) $ findPositionPatterns' allowOpens chord tuning maxHeight
findPositionPatterns' allowOpens chord tuning maxHeight =
scanl1 (flip (\\)) (map (\x-> findPositionPatterns'' allowOpens chord tuning x maxHeight) [0..])
findPositionPatterns'' allowOpens chord tuning from maxHeight = applyIf allowOpens (nub . (++) openPatterns) patterns
where patterns = findPositionPatterns''' False chord tuning from maxHeight
openPatterns = filter (isOpened maxHeight) (findPositionPatterns''' True chord tuning from maxHeight)
isOpened maxHeight positionPattern = (>maxHeight) . getPositionPatternHeight $ positionPattern
getPositionPatternSpannedFrets positionPattern maxHeight
| isOpened maxHeight positionPattern = 0 : ((uncurry enumFromTo) (getPositionPatternRange prunedPositionPattern))
| otherwise = (uncurry enumFromTo) (getPositionPatternRange positionPattern)
where prunedPositionPattern = map (filter (not.(==0))) positionPattern
findPositionPatterns''' includeOpens chord tuning from maxHeight = sequencer $ findPositionPatterns'''' includeOpens chord tuning from maxHeight
where sequencer | requiresSequence chord = filter ( not . null . concat ). map (filter ( not. null)) . sequence . applyIf False addEmpties . deepenListOfLists
| otherwise = (:[])
findPositionPatterns'''' includeOpens chord tuning from maxHeight =
map (\stringTune -> filter (positionInNoteable chord stringTune) (applyIf includeOpens (nub . (0:)) (frettedGuitarStringPostionLength from maxHeight)))
tuning
positionInNoteable noteable stringTuning pos = any (superEquiv note) (newNotes noteable)
where note = tuningAndPosToNote stringTuning pos
frettedGuitarStringPostionLength from maxHeight = [from..(from+maxHeight1)]
class NewNotes a where
newNotes :: a -> [Note]
instance NewNotes Chord where
newNotes = notes
instance NewNotes Scale where
newNotes = notes
instance NewNotes Note where
newNotes n = [n]
getPositionPatternRange = liftM2 (,) getPositionPatternMin getPositionPatternMax
getPositionMultiPatternRange = liftM2 (,) getPositionMultiPatternMin getPositionMultiPatternMax
getPositionMultiPatternHeight = uncurry subtract . getPositionMultiPatternRange
getPositionPatternHeight = uncurry subtract . getPositionPatternRange
getPositionPatternMin = minimum . concat
getPositionPatternMax = maximum . concat
getPositionMultiPatternMax = getPositionPatternMax . concat
getPositionMultiPatternMin = getPositionPatternMin . concat
getPositionMultiPatternMinAdjusted maxHeight = getPositionPatternMinAdjusted maxHeight . concat
getPositionPatternMinAdjusted maxHeight positionPattern
| isOpened maxHeight positionPattern = head . drop 1 . nub . sort . concat $ positionPattern
| otherwise = getPositionPatternMin positionPattern
dropD = [D,A,D,G,B,E]
standardTuning = [E,A,D,G,B,E]
ukelele = [C,E,G,A]
superEquiv a b = equiv a b || equiv b a