DailyProgrammer -- 301 [Hard] Guitar Tablature

Main.hs

-- stack exec -- ghc -O2 Main.hs
-- cat input1.txt | ./Main --sound | aplay

module Main where

import           Control.Applicative
import           Data.List
import           Data.Maybe
import           Data.WAVE
import           Notes
import           Safe                (readMay)
import           System.Environment
import           System.IO           (stdout)

type GuitarChord = [Pitch]
type Bar = [GuitarChord]
type Tab = [Bar]

data Option
  = OutputNames
  | OutputSound

main :: IO ()
main = do
  opt <- parseOptions <$> getArgs
  tab <- parseTab <$> getContents
  case opt of
    OutputNames -> printTab tab
    OutputSound -> playTab  tab

printTab :: Tab -> IO ()
printTab = print
         . unwords
         . map show
         . concat
         . concat

playTab :: Tab -> IO ()
playTab =
          hPutWAVE stdout
        . WAVE (WAVEHeader 1 44100 16 $ Just 10000000)
        -- Just ... is to lazily output the wave file and not run out of memory
        . toSamples 44100
        . toTrack

parseOptions :: [String] -> Option
parseOptions []            = OutputNames
parseOptions ("-n":_)      = OutputNames
parseOptions ("--names":_) = OutputNames
parseOptions ("-s":_)      = OutputSound
parseOptions ("--sound":_) = OutputSound
parseOptions (_:opts)      = parseOptions opts

parseTab :: String -> Tab
parseTab = map
            ( map catMaybes         -- to GuitarChord
            . transpose
            . zipWith stringToPitch guitarStrings
            . parseTabFrets
            )
         . transpose                -- split into bars
         . map separateBars
         . concat                   -- make one long tab
         . groupBy6
         . map (drop 1)             -- remove the note names at the beginning of each line
         . filter (/=[])            -- remove empty lines
         . lines
         . filter (`notElem` " \t") -- simple removal of whitespace

groupBy6 :: [a] -> [[a]]
groupBy6 [] = []
groupBy6 xs = uncurry (:) . fmap groupBy6 . splitAt 6 $ xs

parseTabFrets :: [String] -> [[Maybe Int]]
parseTabFrets ["", "", "", "", "", ""] = [[], [], [], [], [], []]
parseTabFrets xs
  | null $ catMaybes frets = next 1
  | maximum frets > Just 9 = next 2
  | otherwise              = next 1
  where
    frets     = map parseFret xs
    next skip = zipWith (:) frets
              . parseTabFrets
              . map (drop skip)
              $ xs

stringToPitch :: Pitch -> [Maybe Int] -> [Maybe Pitch]
stringToPitch p = map (fmap (fretToPitch p))

fretToPitch :: Pitch -> Int -> Pitch
fretToPitch (Pitch o n) f
  | fromEnum n + f > 11 = fretToPitch (Pitch (o + 1) n) (f - 12)
  | otherwise           = Pitch o (toEnum $ fromEnum n + f)

-- This assumes there is always a '-' after '|' (except at the end of a line)
separateBars :: String -> [String]
separateBars ""       = []
separateBars ('|':xs) = "" : separateBars (drop 1 xs)
separateBars (x:xs)   =
  case separateBars xs of
    []     -> [[x]]
    (y:ys) -> (x:y) : ys

parseFret :: String -> Maybe Int
parseFret ('-':_) = Nothing -- make sure it isn't parsed as a negative number
parseFret xs      = readMay (take 2 xs) <|> readMay (take 1 xs)

guitarStrings :: [Pitch]
guitarStrings =
  [ Pitch 4 E
  , Pitch 3 B
  , Pitch 3 G
  , Pitch 3 D
  , Pitch 2 A
  , Pitch 2 E
  ]

toTrack :: Tab -> [Chord]
toTrack = map (uncurry toChord)
        . concatMap noteLengths
  where
    toChord :: [Pitch] -> Float -> Chord
    toChord [] d = Chord [note d 0.0 $ Pitch 4 A] -- silence
    toChord ps d = Chord $ map (note d a) ps
      where
        a = 1.0 / fromIntegral (length ps)

    note :: Float -> Float -> Pitch -> Note
    note d a  = Note (d * basicDur) a env timbre

    basicDur  = 0.1 -- time equivalent to 1 '-' in the tab
    env       = Envelope 0.05 0.1
    timbre    = map (/ sum harmonics) harmonics
    harmonics = [10, 7, 4, 0, 3, 1.5, 1]

noteLengths :: Bar -> [([Pitch], Float)]
noteLengths = reverse . foldl' go []
  where
    go :: [([Pitch], Float)] -> [Pitch] -> [([Pitch], Float)]
    go []          [] = [([], 1.0)]
    go ((xs,d):ys) [] = (xs, d + 1.0) : ys
    go ys          ps = (ps, 1.0) : ys

Notes.hs

{-# LANGUAGE MagicHash           #-}

module Notes where

import           Data.List
import           Data.WAVE

data NoteName = C | C# | D | D# | E | F | F# | G | G# | A | A# | B
  deriving (Enum, Show)

type Octave = Int
data Pitch = Pitch Octave NoteName

instance Show Pitch where
  show (Pitch o n) = show n ++ show o

{-
----|         duration          |----
----| attack |--------| release |----
-}
data Envelope
  = Envelope
    { attack  :: Float -- in seconds
    , release :: Float -- in seconds
    } deriving Show

data Note
  = Note
    { duration  :: Float    -- in seconds
    , amplitude :: Float    -- in [0..1]
    , envelope  :: Envelope
    , timbre    :: [Float]
    , pitch     :: Pitch
    } deriving Show

newtype Chord = Chord { notes :: [Note] } deriving Show

class Samples a where
  toSamples :: Float -> a -> WAVESamples

instance Samples a => Samples [a] where
  toSamples rate = concatMap (toSamples rate)

instance Samples Chord where
  toSamples rate = mix . map (toSamples rate) . notes

instance Samples Note where
  toSamples rate note
    | amplitude note == 0 = replicate size [0]
    | otherwise           = applyEnvelope rate (envelope note)
                          . take size
                          . (map . map) (amplitude note .*)
                          . applyTimbre (timbre note)
                          . toSamples rate
                          $ pitch note
    where
      size = floor $ duration note * rate

instance Samples Pitch where
  toSamples rate pitch =
    map (\x -> [floor $ maxAmplitude * sin ( 2 * pi * freq * fromIntegral x / rate)]) [0..]
    where
      freq = frequency pitch
      maxAmplitude = 0.95 * fromIntegral (maxBound :: WAVESample)

infixl 6 .*
(.*) :: Float -> WAVESample -> WAVESample
x .* y = floor $ x * fromIntegral y

mix :: [WAVESamples] -> WAVESamples
mix = foldl' (zipWith (zipWith (+))) (repeat [0])

applyTimbre :: [Float] -> WAVESamples -> WAVESamples
applyTimbre weights = mix
                    . zipWith (\w -> (map . map) (w .*)) weights
                    . zipWith skippingStep [0..]
                    . replicate (length weights)
  where
    skippingStep :: Int -> [a] -> [a]
    skippingStep _ []     = []
    skippingStep n (x:xs) = x : skippingStep n (drop n xs)

applyEnvelope :: Float -> Envelope -> WAVESamples -> WAVESamples
applyEnvelope rate env samples =
  concat
    [ linear attackSize $ zip [0..] pre
    , hold
    , linear releaseSize $ zip [releaseSize, pred releaseSize..] post
    ]
  where
    attackSize   = floor $ attack  env * rate
    releaseSize  = floor $ release env * rate
    (pre, rest)  = splitAt attackSize samples
    (hold, post) = splitAt (length rest - releaseSize) rest

    linear :: Int -> [(Int, [WAVESample])] -> WAVESamples
    linear n = map (\(x, s) -> map (fromIntegral x / fromIntegral n .*) s)

frequency :: Pitch -> Float
frequency pitch = referenceFreq * 1.0594630943592953 ** n
  -- 1.0594630943592953 is 2 ** (1/12)
  where
    index (Pitch octave name) = 12 * octave + fromEnum name
    referencePitch = Pitch 4 A
    referenceFreq  = 440.0
    n = fromIntegral $ index pitch - index referencePitch