{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE FlexibleInstances #-}

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 qualified Data.Map

import Music.Instrument.Piano
import Music.Instrument.Common
import Debug.Trace

findPositionPatterns
  allowOpens
  newNoteable
  tuning
  maxHeight
  utilizeAllStrings
  rootNoteLowest
  selectionMask
  utilizeAllNotes
  strictIntervals
  =
  case getChords newNoteable of
   Nothing ->
     map (\c ->
     filter (not . null) $
     findPositionPatterns'
     allowOpens
     c
     tuning
     maxHeight
     utilizeAllStrings
     rootNoteLowest
     selectionMask
     utilizeAllNotes
     strictIntervals
     ) [newNoteable]
   Just chords ->
     map (\c ->
     filter (not . null) $
     findPositionPatterns'
     allowOpens
     c
     tuning
     maxHeight
     utilizeAllStrings
     rootNoteLowest
     selectionMask
     utilizeAllNotes
     strictIntervals
     ) chords

findPositionPatterns'
  allowOpens
  chord
  tuning
  maxHeight
  utilizeAllStrings
  rootNoteLowest
  selectionMask
  utilizeAllNotes
  strictIntervals
  =
  map
  (\x ->
    findPositionPatterns''
    allowOpens
    chord
    tuning
    x
    maxHeight
    utilizeAllStrings
    rootNoteLowest
    selectionMask
    utilizeAllNotes
    strictIntervals
  )
  [0..]

findPositionPatterns''
  allowOpens
  chord
  tuning
  from
  maxHeight
  utilizeAllStrings
  rootNoteLowest
  selectionMask
  utilizeAllNotes
  strictSteps
  =
  applyIf
  allowOpens
  (nub . (++) openPatterns)
  patterns
  where
  patterns =
    findPositionPatterns'''
    False
    chord
    tuning
    from
    maxHeight
    utilizeAllStrings
    rootNoteLowest
    selectionMask
    utilizeAllNotes
    strictSteps
  openPatterns =
    filter
    (isOpened maxHeight)
    (
    findPositionPatterns'''
    True
    chord
    tuning
    from
    maxHeight
    utilizeAllStrings
    rootNoteLowest
    selectionMask
    utilizeAllNotes
    strictSteps
    )

getPositionPatternSpannedFrets positionPattern maxHeight
  = applyIf isOpened' (0:) ((uncurry enumFromTo) range)
  where
  range = if isOpened' then (getPositionPatternMin prunedPositionPattern,getPositionPatternMin prunedPositionPattern + maxHeight)
                       else (getPositionPatternMin positionPattern,getPositionPatternMin positionPattern + maxHeight)
  isOpened' = isOpened maxHeight positionPattern
  prunedPositionPattern = map (filter (not.(==0))) positionPattern

isOpened maxHeight positionPattern = (>maxHeight) . getPositionPatternHeight $ positionPattern

findPositionPatterns'''
  includeOpens
  chord
  tuning
  from
  maxHeight
  utilizeAllStrings
  rootNoteLowest
  selectionMask
  utilizeAllNotes
  strictIntervals
    = sequencer $ findPositionPatterns'''' includeOpens chord tuning from maxHeight strictIntervals
    where
      sequencer | requiresSequence' chord
        = (\v -> (   filter (not . null . concat)
                   . (\x -> filter (\a -> length (strip a) == maximum (map length (map strip x))) x)
                  . applyIf utilizeAllStrings (filter (\x -> length (concat x) == length tuning))
                   . applyIf (isSlash chord) (filter (\x -> (nub $ sort $ drop 1 (concat (zipWith (\ps t -> map (tuningAndPosToNote t) ps) x tuning)))  == (nub $ sort $ drop 1 $ newNotes chord)))
                   . applyIf utilizeAllNotes (filter (\x -> (nub $ sort $ concat (zipWith (\ps t -> map (tuningAndPosToNote t) ps) x tuning))  == (nub $ sort (newNotes chord))))
                   . applyIf rootNoteLowest (filter (\x -> take 1 (concat (zipWith (\ps t -> map (tuningAndPosToNote t) ps) x tuning))  == take 1 (newNotes chord)))
                   . applyIf (not utilizeAllStrings && (not . null $ selectionMask)) (filter (\x ->
                       or (
                          map (\selectionMask'' ->
                            all (\(a,b) -> if a then b /= [] else b == []) (zip selectionMask'' x)
                         ) selectionMask
                       )
                     ))
                   . sequence
                   ) v)
                   . addEmpties
                   . deepenListOfLists
                | otherwise = (:[])

strip = filter (not . null)

findPositionPatterns''''
  includeOpens
  chord
  tuning
  from
  maxHeight
  strictIntervals
  =
  map
  (\interval ->
    filter
    (
    if strictIntervals
    then positionInInterval chord interval
    else positionInNoteable chord interval
    )
    (applyIf
     includeOpens
     (nub . (0:))
     (frettedGuitarStringPostionLength from maxHeight)
    )
  )
  (notesToSteps tuning)

positionInInterval
  intervalable
  stringInterval
  pos
  =
  any
  (==(pos + stringInterval))
  (getSteps $ lastIntervals intervalable)

positionInNoteable
  noteable
  stringInterval
  pos
  =
  any
  (superEquiv note)
  (newNotes noteable)
  where
  note =
   tuningAndPosToNote
   stringTuning
   pos
  stringTuning = stepToNote stringInterval

frettedGuitarStringPostionLength from maxHeight = [from..(from+maxHeight-1)]

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 =
  if isOpened maxHeight positionPattern then head . drop 1 . nub . sort . concat $ positionPattern
                                        else getPositionPatternMin positionPattern

lightChord = [
   [False,False,True,True,True,True]
  ,[False,False,False,True,True,True]
 ]

powerChord = [
              [True,True,True,False,False,False]
             ,[False,True,True,True,False,False]
             ]

standardWidths =            [
              [True,True,True,True,True,True]
             ,[False,True,True,True,True,True]
             ]

dropD = [D,A,D,G,B,E]
ukelele = [C,E,G,A]
standardTuning = [E,A,D,G,B,E]
fifthChord n = [n , applyNTimes sharp 7 n]

sus2 chord = (x:canonize(flat(flat y)):xs)
  where (x:y:xs) = newNotes chord
sus4 chord = (x:canonize(sharp y):xs)
  where (x:y:xs) = newNotes chord

superEquiv a b = equiv a b || equiv b a