src/RMCA/GUI/NoteSettings.hs

   1 {-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, ScopedTypeVariables,
   2              TupleSections #-}
   3
   4 module RMCA.GUI.NoteSettings where
   5
   6 import Control.Monad
   7 import Data.List
   8 import Data.Maybe
   9 import Data.Ord
  10 import Data.Ratio
  11 import Data.ReactiveValue
  12 import Data.String
  13 import Data.Tuple
  14 import Graphics.UI.Gtk          hiding (Action)
  15 import Graphics.UI.Gtk.Reactive
  16 import RMCA.Auxiliary
  17 import RMCA.GUI.Board
  18 import RMCA.MCBMVar
  19 import RMCA.Semantics
  20
  21 setNAttr :: NoteAttr -> Action -> Action
  22 setNAttr _ Inert = Inert
  23 setNAttr _ Absorb = Absorb
  24 setNAttr na (Stop _) = Stop na
  25 setNAttr na (ChDir b _ dir) = ChDir b na dir
  26 setNAttr na (Split _) = Split na
  27
  28 getNAttr :: Action -> Maybe NoteAttr
  29 getNAttr Inert = Nothing
  30 getNAttr Absorb = Nothing
  31 getNAttr (Stop na) = Just na
  32 getNAttr (ChDir _ na _) = Just na
  33 getNAttr (Split na) = Just na
  34
  35 symbolString :: [(Duration,String)]
  36 symbolString = map (\(_,y,z) -> (z,y)) noteSymbList
  37
  38 noteList :: [(String,Duration)]
  39 noteList = map (\(x,_,y) -> (x,y)) noteSymbList
  40
  41 noteList' :: [(String,Duration)]
  42 noteList' = map (\(x,y,z) -> (x ++ " " ++ y,z)) noteSymbList
  43
  44 noteSymbList :: [(String, String, Duration)]
  45 noteSymbList = sortBy (comparing (\(_,_,x) -> x))
  46                [ ("♩", "Quarter note", 1 % 4)
  47                , ("♪", "Eighth note ", 1 % 8)
  48                , ("𝅗𝅥", "Half note", 1 % 2)
  49                , ("𝅘𝅥𝅯", "Sixteenth note", 1 % 16)
  50                , ("𝅝", "Whole note", 1)
  51                ]
  52
  53 comboBoxIndexRV :: (ComboBoxClass box) =>
  54                    box -> ReactiveFieldReadWrite IO Int
  55 comboBoxIndexRV box = ReactiveFieldReadWrite setter getter notifier
  56   where getter = comboBoxGetActive box
  57         setter = comboBoxSetActive box
  58         notifier = void . on box changed
  59
  60 noteSettingsBox :: IO (VBox, MCBMVar GUICell)
  61 noteSettingsBox = do
  62   pieceBox <- vBoxNew False 5
  63   naBox <- vBoxNew False 5
  64   boxPackStart pieceBox naBox PackNatural 0
  65
  66   -- Articulation box
  67   artCombo <- comboBoxNewText
  68   artIndex <- mapM (\art -> do i <- comboBoxAppendText artCombo
  69                                     (fromString $ show art)
  70                                return (art,i)) [NoAccent ..]
  71   comboBoxSetActive artCombo 0
  72   boxPackStart naBox artCombo PackNatural 0
  73   let indexToArt i =
  74         fromMaybe (error "In indexToArt: failed \
  75                          \to find the selected \
  76                          \articulation.") $ lookup i $ map swap artIndex
  77       artToIndex a = fromMaybe (error "In artToIndex: failed \
  78                                       \to find the correct index \
  79                                       \for the \
  80                                       \articulation.") $ lookup a artIndex
  81       artComboRV = bijection (indexToArt,artToIndex) `liftRW`
  82                    comboBoxIndexRV artCombo
  83
  84   -- Slide box
  85   slideCombo <- comboBoxNewText
  86   slideIndex <- mapM (\sli -> do i <- comboBoxAppendText slideCombo
  87                                       (fromString $ show sli)
  88                                  return (sli,i)) [NoSlide ..]
  89   comboBoxSetActive slideCombo 0
  90   boxPackStart naBox slideCombo PackNatural 0
  91   let indexToSlide i =
  92         fromMaybe (error "In indexToSlide: failed \
  93                          \to find the correct slide \
  94                          \for the selected \
  95                          \index.") $ lookup i $ map swap slideIndex
  96       slideToIndex s =
  97         fromMaybe (error "In slideToIndex: failed \
  98                          \to find \
  99                          \the correct index \
 100                          \for the slide.") $ lookup s slideIndex
 101       slideComboRV = bijection (indexToSlide,slideToIndex) `liftRW`
 102                      comboBoxIndexRV slideCombo
 103
 104   -- Note duration box
 105   noteDurBox <- hBoxNew False 10
 106   noteDurCombo <- comboBoxNewText
 107   noteDurIndex <- mapM (\(str,dur) -> do i <- comboBoxAppendText noteDurCombo
 108                                               (fromString str)
 109                                          return (dur,i)) noteList
 110   comboBoxSetActive noteDurCombo 0
 111   let indexToDur i =
 112         fromMaybe (error "In indexToDur: failed \
 113                          \to find the correct \
 114                          \ duration for the \
 115                          \selected index.") $ lookup i $ map swap noteDurIndex
 116       durToIndex d =
 117         fromMaybe (error "In durToIndex: \
 118                          \failed to find \
 119                          \the correct index \
 120                          \for the duration.") $ lookup d noteDurIndex
 121       noteDurRV = bijection (indexToDur, durToIndex) `liftRW`
 122                   comboBoxIndexRV noteDurCombo
 123   noteDurLabel <- labelNew =<< (`lookup` symbolString) <$> reactiveValueRead noteDurRV
 124   let noteDurLabelRV = labelTextReactive noteDurLabel
 125   boxPackStart naBox noteDurBox PackNatural 0
 126   boxPackStart noteDurBox noteDurCombo PackNatural 0
 127   boxPackStart noteDurBox noteDurLabel PackNatural 0
 128
 129   -- Repeat count box
 130   rCountAdj <- adjustmentNew 1 0 100 1 1 0
 131   rCount <- spinButtonNew rCountAdj 1 0
 132   boxPackStart pieceBox rCount PackNatural 0
 133   let rCountRV = spinButtonValueIntReactive rCount
 134
 135   -- Side RV
 136   -- Carries the index of the tile to display and what to display.
 137   setRV <- newMCBMVar inertCell
 138
 139   reactiveValueOnCanRead noteDurRV $ do
 140     nDur <- reactiveValueRead noteDurRV
 141     oCell <- reactiveValueRead setRV
 142     let nCa :: Maybe NoteAttr
 143         nCa = (\na -> na { naDur = nDur }) <$> getNAttr (cellAction oCell)
 144         nCell :: GUICell
 145         nCell = if isJust nCa
 146                 then oCell { cellAction =
 147                              setNAttr (fromJust nCa) (cellAction oCell) }
 148                 else oCell
 149     reactiveValueWriteOnNotEq setRV nCell
 150     fromMaybeM_ $ reactiveValueWrite noteDurLabelRV <$> lookup nDur symbolString
 151
 152
 153   reactiveValueOnCanRead rCountRV $ do
 154     nRCount <- reactiveValueRead rCountRV
 155     oCell <- reactiveValueRead setRV
 156     let nCell = oCell { repeatCount = nRCount }
 157     reactiveValueWrite setRV nCell
 158
 159   reactiveValueOnCanRead slideComboRV $ do
 160     nSlide <- reactiveValueRead slideComboRV
 161     oCell <- reactiveValueRead setRV
 162     let nCa :: Maybe NoteAttr
 163         nCa = (\na -> na { naOrn = (naOrn na) { ornSlide = nSlide } }) <$>
 164               getNAttr (cellAction oCell)
 165         nCell :: GUICell
 166         nCell = if isJust nCa
 167                 then oCell { cellAction =
 168                              setNAttr (fromJust nCa) (cellAction oCell)
 169                            }
 170                 else oCell
 171     reactiveValueWrite setRV nCell
 172
 173   reactiveValueOnCanRead artComboRV $ do
 174     nArt <- reactiveValueRead artComboRV
 175     oCell <- reactiveValueRead setRV
 176     let nCa :: Maybe NoteAttr
 177         nCa = (\na -> na { naArt = nArt }) <$> getNAttr (cellAction oCell)
 178         nCell :: GUICell
 179         nCell = if isJust nCa
 180                 then oCell { cellAction =
 181                              setNAttr (fromJust nCa) (cellAction oCell) }
 182                 else oCell
 183     reactiveValueWrite setRV nCell
 184
 185   let hideNa :: IO ()
 186       hideNa = do widgetHide slideCombo
 187                   widgetHide artCombo
 188                   widgetShow rCount
 189                   widgetHideAll noteDurBox
 190       showNa :: IO ()
 191       showNa = do widgetShow slideCombo
 192                   widgetShow artCombo
 193                   widgetShow rCount
 194                   widgetShowAll noteDurBox
 195       updateNaBox :: GUICell -> IO ()
 196       updateNaBox GUICell { cellAction = act } = case act of
 197         Inert -> hideNa
 198         Absorb -> hideNa
 199         _ -> showNa
 200
 201   reactiveValueOnCanRead setRV $ postGUIAsync $ do
 202     nCell <- reactiveValueRead setRV
 203     fromMaybeM_ (reactiveValueWriteOnNotEq artComboRV . naArt <$>
 204                   getNAttr (cellAction nCell))
 205     fromMaybeM_ (reactiveValueWriteOnNotEq slideComboRV . ornSlide . naOrn <$>
 206                   getNAttr (cellAction nCell))
 207     reactiveValueWriteOnNotEq rCountRV $ repeatCount nCell
 208     fromMaybeM_ (reactiveValueWriteOnNotEq noteDurRV . naDur <$>
 209                   getNAttr (cellAction nCell))
 210     updateNaBox nCell
 211
 212   widgetShow pieceBox
 213   widgetShow naBox
 214   return (pieceBox,setRV)