Quick and dirty scale learning script

notes.hs

module Main where

import Control.Monad
import Data.List
import System.Random
import Data.Map (Map)
import Data.Bool
import Text.Read
import Data.Maybe
import qualified Data.Map as Map
import qualified Data.Char as Char

chordTones :: [Int]
chordTones = [1,3,5,7]

arps :: IO ()
arps = do
 let perms = sort $ permutations chordTones
 forM_ (zip [1..] perms) $ \(n, tones) -> do
    putStrLn $ show n ++ ".)\t" ++ intercalate " " (map show tones)

notes :: [Char]
notes = "CDEFGABC"

accidentials :: [Char]
accidentials = "‚ôØ‚ô≠"

data Note = Sharp Char | Flat Char | Natural Char

instance Show Note where
  -- show (Sharp note) = note : "‚ôØ"
  -- show (Flat note) = note : "‚ô≠"
  show (Sharp note) = note : "#"
  show (Flat note) = note : "b"
  show (Natural note) = note : ""

c_scale :: [Note]
c_scale =
  [Natural 'C', Natural 'D', Natural 'E', Natural 'F', Natural 'G', Natural 'A', Natural 'B']

g_scale :: [Note]
g_scale =
  [Natural 'G', Natural 'A', Natural 'B', Natural 'C', Natural 'D', Natural 'E', Sharp 'F']

gb_scale :: [Note]
gb_scale =
  [Flat 'G', Flat 'A', Flat 'B', Flat 'C', Flat 'D', Flat 'E', Natural 'F']

d_scale :: [Note]
d_scale =
  [Natural 'D', Natural 'E', Sharp 'F', Natural 'G', Natural 'A', Natural 'B', Sharp 'C']

db_scale :: [Note]
db_scale =
  [Flat 'D', Flat 'E', Natural 'F', Flat 'G', Flat 'A', Flat 'B', Natural 'C']

a_scale :: [Note]
a_scale =
  [Natural 'A', Natural 'B', Sharp 'C', Natural 'D', Natural 'E', Sharp 'F', Sharp 'G']

ab_scale :: [Note]
ab_scale =
  [Flat 'A', Flat 'B', Natural 'C', Flat 'D', Flat 'E', Natural 'F', Natural 'G']

e_scale :: [Note]
e_scale =
  [Natural 'E', Sharp 'F', Sharp 'G', Natural 'A', Natural 'B', Sharp 'C', Sharp 'D']

eb_scale :: [Note]
eb_scale =
  [Flat 'E', Natural 'F', Natural 'G', Flat 'A', Flat 'B', Natural 'C', Natural 'D']

b_scale :: [Note]
b_scale =
  [Natural 'B', Sharp 'C', Sharp 'D', Natural 'E', Sharp 'F', Sharp 'G', Sharp 'A']

bb_scale :: [Note]
bb_scale =
  [Flat 'B', Natural 'C', Natural 'D', Flat 'E', Natural 'F', Natural 'G', Natural 'A']

f_scale :: [Note]
f_scale =
  [Natural 'F', Natural 'G', Natural 'A', Flat 'B', Natural 'C', Natural 'D', Natural 'E']

fis_scale :: [Note]
fis_scale =
  [Sharp 'F', Sharp 'G', Sharp 'A', Natural 'B', Sharp 'C', Sharp 'D', Sharp 'E']

scales :: [(String, [Note])]
scales =
  [ ("B", b_scale)
  , ("Bb", bb_scale)
  , ("F", f_scale)
  , ("F#", fis_scale)
  , ("D", d_scale)
  , ("Db", db_scale)
  , ("A", a_scale)
  , ("Ab", ab_scale)
  , ("G", g_scale)
  , ("Gb", gb_scale)
  , ("E", e_scale)
  , ("Eb", eb_scale)
  , ("C", c_scale)
  ]

askNote ::  String -> [Note] -> IO Bool
askNote name scale = do
  deg <- randomRIO (1, 7 :: Int)
  let note = scale !! (deg - 1)
  putStrLn $ show deg ++ " in " ++ name
  guess <- getLine
  return $ capitalize guess == show note
  where
    capitalize (x:xs) = Char.toUpper x : xs
    capitalize xs = xs

askDegree :: String -> [Note] -> IO Bool
askDegree name scale = do
  idx <- randomRIO (0, 6 :: Int)
  let note = scale !! idx
  putStrLn $ show note ++ " in " ++ name
  guess <- getChar
  return $ fromMaybe 0 (readMaybe (guess : [])) == idx + 1

askQuestions :: (String -> [Note] -> IO Bool) -> IO ()
askQuestions gen = do
  forM_ scales $ \scale@(name, _) -> do
    putStrLn $ "------- " ++ name ++ " -------"
    forM_ [1..50] $ \i -> do
      result <- uncurry gen scale
      let result' = bool "WRONG" "CORRECT" result
      putStrLn $ '\n' : result' ++ " (" ++ show i ++ ")"

main :: IO ()
main = do
  askQuestions askNote
  askQuestions askDegree