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 =<< fmap (`lookup` symbolString)
 124                                     (reactiveValueRead noteDurRV)
 125   let noteDurLabelRV = labelTextReactive noteDurLabel
 126   boxPackStart naBox noteDurBox PackNatural 0
 127   boxPackStart noteDurBox noteDurCombo PackNatural 0
 128   boxPackStart noteDurBox noteDurLabel PackNatural 0
 129
 130   -- Repeat count box
 131   rCountAdj <- adjustmentNew 1 0 100 1 1 0
 132   rCount <- spinButtonNew rCountAdj 1 0
 133   boxPackStart pieceBox rCount PackNatural 0
 134   let rCountRV = spinButtonValueIntReactive rCount
 135
 136   -- Side RV
 137   -- Carries the index of the tile to display and what to display.
 138   setRV <- newMCBMVar inertCell
 139
 140   reactiveValueOnCanRead noteDurRV $ do
 141     nDur <- reactiveValueRead noteDurRV
 142     oCell <- reactiveValueRead setRV
 143     let nCa :: Maybe NoteAttr
 144         nCa = fmap (\na -> na { naDur = nDur }) (getNAttr (cellAction oCell))
 145         nCell :: GUICell
 146         nCell = if isJust nCa
 147                 then oCell { cellAction =
 148                              setNAttr (fromJust nCa) (cellAction oCell) }
 149                 else oCell
 150     reactiveValueWriteOnNotEq setRV nCell
 151     fromMaybeM_ $ fmap (reactiveValueWrite noteDurLabelRV)
 152                        (lookup nDur symbolString)
 153
 154
 155   reactiveValueOnCanRead rCountRV $ do
 156     nRCount <- reactiveValueRead rCountRV
 157     oCell <- reactiveValueRead setRV
 158     let nCell = oCell { repeatCount = nRCount }
 159     reactiveValueWrite setRV nCell
 160
 161   reactiveValueOnCanRead slideComboRV $ do
 162     nSlide <- reactiveValueRead slideComboRV
 163     oCell <- reactiveValueRead setRV
 164     let nCa :: Maybe NoteAttr
 165         nCa = fmap (\na -> na { naOrn = (naOrn na) { ornSlide = nSlide } })
 166                    (getNAttr (cellAction oCell))
 167         nCell :: GUICell
 168         nCell = if isJust nCa
 169                 then oCell { cellAction =
 170                              setNAttr (fromJust nCa) (cellAction oCell)
 171                            }
 172                 else oCell
 173     reactiveValueWrite setRV nCell
 174
 175   reactiveValueOnCanRead artComboRV $ do
 176     nArt <- reactiveValueRead artComboRV
 177     oCell <- reactiveValueRead setRV
 178     let nCa :: Maybe NoteAttr
 179         nCa = fmap (\na -> na { naArt = nArt }) (getNAttr (cellAction oCell))
 180         nCell :: GUICell
 181         nCell = if isJust nCa
 182                 then oCell { cellAction =
 183                              setNAttr (fromJust nCa) (cellAction oCell) }
 184                 else oCell
 185     reactiveValueWrite setRV nCell
 186
 187   let hideNa :: IO ()
 188       hideNa = do widgetHide slideCombo
 189                   widgetHide artCombo
 190                   widgetShow rCount
 191                   widgetHideAll noteDurBox
 192       showNa :: IO ()
 193       showNa = do widgetShow slideCombo
 194                   widgetShow artCombo
 195                   widgetShow rCount
 196                   widgetShowAll noteDurBox
 197       updateNaBox :: GUICell -> IO ()
 198       updateNaBox GUICell { cellAction = act } = case act of
 199         Inert -> hideNa
 200         Absorb -> hideNa
 201         _ -> showNa
 202
 203   reactiveValueOnCanRead setRV $ postGUIAsync $ do
 204     nCell <- reactiveValueRead setRV
 205     fromMaybeM_ (fmap (reactiveValueWriteOnNotEq artComboRV . naArt)
 206                       (getNAttr (cellAction nCell)))
 207     fromMaybeM_ (fmap (reactiveValueWriteOnNotEq slideComboRV
 208                        . ornSlide . naOrn)
 209                       (getNAttr (cellAction nCell)))
 210     reactiveValueWriteOnNotEq rCountRV $ repeatCount nCell
 211     fromMaybeM_ (fmap (reactiveValueWriteOnNotEq noteDurRV . naDur)
 212                       (getNAttr (cellAction nCell)))
 213     updateNaBox nCell
 214
 215   widgetShow pieceBox
 216   widgetShow naBox
 217   return (pieceBox,setRV)