module Music.Instrument.GuitarRender 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.Guitar (
findPositionPatterns
,getPositionMultiPatternMin
,getPositionPatternProgressions
,PositionPatternProgression
,getPositionMultiPatternMinAdjusted
,getPositionPatternMinAdjusted
,getPositionPatternHeight
,getPositionPatternSpannedFrets)
import Music.Instrument.Piano
import Music.Instrument.Common (ControlAnnotation (..),tuningAndPosToNote,abbreviateNote,horizontalConcat,applyIf,insertAt)
import Debug.Trace
renderGuitarChord :: PositionPatternProgression a => Bool -> ControlAnnotation -> Bool -> Bool -> Bool -> [Note] -> a -> Int -> Int -> [Char]
renderGuitarChord allowOpens controlAnnotation annotateFrets firstTuningFirst orientationVertical tuning chord maxHeight from =
head $
renderGuitarChord' controlAnnotation annotateFrets firstTuningFirst orientationVertical tuning maxHeight from positionPatternProgressions
where positionPatternProgressions = getPositionPatternProgressions allowOpens chord tuning maxHeight
renderGuitarChord' controlAnnotation annotateFrets firstTuningFirst orientationVertical tuning maxHeight from positionPatternsProgressions =
drop from $
map (renderGuitarChord'' controlAnnotation annotateFrets firstTuningFirst orientationVertical tuning maxHeight) positionPatternsProgressions
renderGuitarChord'' controlAnnotation annotateFrets firstTuningFirst orientationVertical tuning maxHeight positionPatterns =
concat $ intersperse "\n" $
renderPositionPatternsRange annotateFrets firstTuningFirst orientationVertical controlAnnotation tuning maxHeight positionPatterns
renderPositionPatternsRange annotateFrets firstTuningFirst orientationVertical controlAnnotation tuning maxHeight positionPatterns' =
map (renderPositionPattern annotateFrets firstTuningFirst orientationVertical controlAnnotation tuning minPosition (maxHeight1)) positionPatterns'
where minPosition = getPositionMultiPatternMin positionPatterns'
renderPositionPattern annotateFrets firstTuningFirst orientationVertical controlAnnotation tuning from maxHeight positionPattern =
heading $ unlines $ renderPositionPattern' annotateFrets firstTuningFirst orientationVertical controlAnnotation tuning from maxHeight positionPattern
where minPositionAdjusted = getPositionPatternMinAdjusted maxHeight positionPattern
heading | minPositionAdjusted /= 0 = (++) ("Fret: " ++ show minPositionAdjusted ++ "\n")
| otherwise = id
renderPositionPattern' annotateFrets firstTuningFirst orientationVertical controlAnnotation tuning from maxHeight positionPattern =
guitarStringTexts
where guitarStringTexts = applyIf orientationVertical (map reverse . Data.List.transpose) guitarStringTexts'
guitarStringTexts' = applyIf annotateFrets (++ (Data.List.transpose fretAnnotations)) guitarStringTexts''
fretAnnotations = map (overlayStringRight fretAnnotationPadding) fretAnnotations'
overlayStringRight x y = map last $ Data.List.transpose [x,y]
fretAnnotationPadding = take maximumFretAnnotationLength (repeat ' ')
maximumFretAnnotationLength = maximum . map length $ fretAnnotations'
fretAnnotations' = map show $ take (maxHeight'+1) [0..]
guitarStringTexts'' =
map (\(pos,stringIndex)
-> renderGuitarString' stringIndex orientationVertical controlAnnotation from maxHeight' pos (tuning'!!stringIndex) positionPatternSpannedFrets)
(zip (reverse positionPattern) stringIndicies)
stringIndicies | firstTuningFirst = [0..]
| otherwise = [guitarStringCount1,guitarStringCount2..]
guitarStringCount = length positionPattern
maxHeight' = getPositionPatternHeight positionPattern
minHeight' = getPositionPatternHeight positionPattern
positionPatternSpannedFrets = getPositionPatternSpannedFrets positionPattern maxHeight
minPositionAdjusted = getPositionPatternMinAdjusted maxHeight positionPattern
tuning' = reverse tuning
firstGap [] = Nothing
firstGap xs = listToMaybe (take 1 $ map fst $ dropWhile (uncurry (==)) $ zip [head xs..] xs)
renderGuitarString' stringIndex orientationVertical controlAnnotation from max positionIndices stringTuning positionPatternSpannedFrets =
applyIf (not (positionPatternsGap == Nothing)) (addGap positionPatternsGap)
$ map (char stringIndex orientationVertical stringTuning positionIndices controlAnnotation) positionPatternSpannedFrets
where positionPatternsGap = firstGap positionPatternSpannedFrets
addGap (Just n) str = insertAt n (gapChar orientationVertical) str
gapChar orientationVertical | orientationVertical = '~'
| otherwise = 'S'
char stringIndex orientationVertical stringTuning positionIndices controlAnnotation index
| index `elem` positionIndices = fingeringChar stringIndex stringTuning index controlAnnotation
| otherwise = fretChar orientationVertical index
fingeringChar stringIndex stringTuning positionIndex controlAnnotation =
case controlAnnotation of
AnnotateNote -> abbreviateNote $ tuningAndPosToNote stringTuning positionIndex
AnnotateMarking -> fingeringCharUnannotated positionIndex
AnnotatePositionVertical -> head (show positionIndex)
AnnotatePositionHorizontal -> head (show stringIndex)
fretChar orientationVertical 0 | orientationVertical = '='
| otherwise = '|'
fretChar orientationVertical _ | orientationVertical = '-'
| otherwise = '-'
fingeringCharUnannotated 0 = 'o'
fingeringCharUnannotated _ = '*'
rotateText = unlines . Data.List.transpose . lines