midimory-0.0.1: src/Configuration.hs

module Configuration where

import qualified Sound.ALSA.Sequencer.Event as Event

import qualified Options.Applicative as OP

import qualified Control.Functor.HT as FuncHT
import Control.Applicative (liftA2, liftA3)

import qualified Data.Map as Map
import qualified Data.List as List
import Data.Map (Map)
import Data.Bool.HT (if')
import Data.Monoid ((<>))


data T =
   Cons {
      rows, columns :: Int,
      texts :: [[String]],
      pitches :: [Event.Pitch]
   }

create :: [[String]] -> [Event.Pitch] -> T
create ts ps =
   Cons {
      rows = length ts,
      columns = maximum (map length ts),
      texts = ts,
      pitches = ps
   }

board4x4, board4x4sg, board4x6sg, board6x6sg :: T
board4x4 =
   create
      (FuncHT.outerProduct (\r c -> [r,c]) ['A'..'D'] ['0'..'3'])
      (map (Event.Pitch . (60+)) [0,2,4,5,7,9,11,12])

board4x4sg =
   create
      (map (map (:[])) ["SPR*", "*ACH", "GIT*", "*TER"])
      (map (Event.Pitch . (60+)) [0,2,4,5,7,9,11,12])

board4x6sg =
   create
      (map (map (:[])) $ concat $ replicate 2 ["SPRACH", "GITTER"])
      (map (Event.Pitch . (60+)) [0..11])

board6x6sg =
   create
      (map (map (:[])) $ concat $ replicate 3 ["SPRACH", "GITTER"])
      (map (Event.Pitch . (60+)) [0..17])


parseSize :: String -> Either String (Int,Int)
parseSize str =
   let parser str0 = do
         (width, 'x':str1) <- reads str0
         (height, "") <- reads str1
         return (width,height)
   in  case parser str of
         [(width,height)] ->
            if' (width<0) (Left "Negative width") $
            if' (height<0) (Left "Negative height") $
            if' (width>10) (Left "Width larger than 10") $
            if' (height>10) (Left "Height larger than 10") $
            if' (mod (width*height) 2 /= 0)
               (Left "Board needs an even number of fields") $
            Right (fromInteger width, fromInteger height)
         _ -> Left "MIDI pitch must be a number"

optionBoardSize :: OP.Parser (Int,Int)
optionBoardSize =
   OP.option (OP.eitherReader parseSize) $
      OP.long "board-size" <>
      OP.metavar "WIDTHxHEIGHT" <>
      OP.value (4,4) <>
      OP.help "Board geometry (default: 4x4)"


majorScale, minorScale, chromaticScale :: [Int]
majorScale = [0,2,4,5,7,9,11]
minorScale = [0,2,3,5,7,8,10]
chromaticScale = [0..11]

scales :: Map String [Int]
scales =
   Map.fromList $
      ("major", majorScale) :
      ("minor", minorScale) :
      ("chromatic", chromaticScale) :
      []

parseScale :: String -> Either String [Int]
parseScale str =
   case Map.lookup str scales of
      Just scale -> Right scale
      Nothing ->
         Left $
            "Scale must be one of: " ++ List.intercalate ", " (Map.keys scales)

optionScale :: OP.Parser [Int]
optionScale =
   OP.option (OP.eitherReader parseScale)
      (OP.long "musical-scale" <>
       OP.metavar "NAME" <>
       OP.value [] <>
       OP.help "Musical scale for notes")


parsePitch :: String -> Either String Event.Pitch
parsePitch str =
   case reads str of
      [(pitch, "")] ->
         if' (pitch<0) (Left "Negative MIDI pitch") $
         if' (pitch>=128) (Left "MIDI pitch larger than 127") $
         Right $ Event.Pitch $ fromInteger pitch
      _ -> Left "MIDI pitch must be a number"

optionZerokey :: OP.Parser Event.Pitch
optionZerokey =
   OP.option (OP.eitherReader parsePitch)
      (OP.long "zerokey" <>
       OP.metavar "INT" <>
       OP.value (Event.Pitch 60) <>
       OP.help "MIDI pitch for the lowest note (default: 60)")


option :: OP.Parser (Either String T)
option =
   liftA3
      (\(w,h) scalePlain zeroKey ->
         let numTones = div (w*h) 2
             zk = Event.unPitch zeroKey
         in if' (fromIntegral zk + numTones >= 128)
               (Left "Highest pitch outside MIDI scale") $
            Right $
            create
               (FuncHT.outerProduct (\r c -> [r,c])
                  (take h ['A'..]) (take w ['0'..]))
               (let scale =
                      if null scalePlain
                        then if numTones>8 then chromaticScale else majorScale
                        else scalePlain
                in  map (Event.Pitch . (zk +) . fromIntegral) $
                    take numTones $ liftA2 (+) [0,12..] scale))
      optionBoardSize
      optionScale
      optionZerokey