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                [ ("𝄽", "No note", 0)
  47                , ("♩", "Quarter note", 1 % 4)
  48                , ("♪", "Eighth note ", 1 % 8)
  49                , ("𝅗𝅥", "Half note", 1 % 2)
  50                , ("𝅘𝅥𝅯", "Sixteenth note", 1 % 16)
  51                , ("𝅝", "Whole note", 1)
  52                ]
  53
  54 comboBoxIndexRV :: (ComboBoxClass box) =>
  55                    box -> ReactiveFieldReadWrite IO Int
  56 comboBoxIndexRV box = ReactiveFieldReadWrite setter getter notifier
  57   where getter = comboBoxGetActive box
  58         setter = comboBoxSetActive box
  59         notifier = void . on box changed
  60
  61 noteSettingsBox :: IO (VBox, MCBMVar GUICell)
  62 noteSettingsBox = do
  63   pieceBox <- vBoxNew False 5
  64   naBox <- vBoxNew False 5
  65   boxPackStart pieceBox naBox PackNatural 0
  66
  67   -- Articulation box
  68   artCombo <- comboBoxNewText
  69   artIndex <- mapM (\art -> do i <- comboBoxAppendText artCombo
  70                                     (fromString $ show art)
  71                                return (art,i)) [NoAccent ..]
  72   comboBoxSetActive artCombo 0
  73   boxPackStart naBox artCombo PackNatural 0
  74   let indexToArt i =
  75         fromMaybe (error "In indexToArt: failed \
  76                          \to find the selected \
  77                          \articulation.") $ lookup i $ map swap artIndex
  78       artToIndex a = fromMaybe (error "In artToIndex: failed \
  79                                       \to find the correct index \
  80                                       \for the \
  81                                       \articulation.") $ lookup a artIndex
  82       artComboRV = bijection (indexToArt,artToIndex) `liftRW`
  83                    comboBoxIndexRV artCombo
  84
  85   -- Slide box
  86   slideCombo <- comboBoxNewText
  87   slideIndex <- mapM (\sli -> do i <- comboBoxAppendText slideCombo
  88                                       (fromString $ show sli)
  89                                  return (sli,i)) [NoSlide ..]
  90   comboBoxSetActive slideCombo 0
  91   boxPackStart naBox slideCombo PackNatural 0
  92   let indexToSlide i =
  93         fromMaybe (error "In indexToSlide: failed \
  94                          \to find the correct slide \
  95                          \for the selected \
  96                          \index.") $ lookup i $ map swap slideIndex
  97       slideToIndex s =
  98         fromMaybe (error "In slideToIndex: failed \
  99                          \to find \
 100                          \the correct index \
 101                          \for the slide.") $ lookup s slideIndex
 102       slideComboRV = bijection (indexToSlide,slideToIndex) `liftRW`
 103                      comboBoxIndexRV slideCombo
 104
 105   -- Note duration box
 106   noteDurBox <- hBoxNew False 10
 107   noteDurCombo <- comboBoxNewText
 108   noteDurIndex <- mapM (\(str,dur) -> do i <- comboBoxAppendText noteDurCombo
 109                                               (fromString str)
 110                                          return (dur,i)) noteList
 111   comboBoxSetActive noteDurCombo 0
 112   let indexToDur i =
 113         fromMaybe (error "In indexToDur: failed \
 114                          \to find the correct \
 115                          \ duration for the \
 116                          \selected index.") $ lookup i $ map swap noteDurIndex
 117       durToIndex d =
 118         fromMaybe (error "In durToIndex: \
 119                          \failed to find \
 120                          \the correct index \
 121                          \for the duration.") $ lookup d noteDurIndex
 122       noteDurRV = bijection (indexToDur, durToIndex) `liftRW`
 123                   comboBoxIndexRV noteDurCombo
 124   noteDurLabel <- labelNew =<< fmap (`lookup` symbolString)
 125                                     (reactiveValueRead noteDurRV)
 126   let noteDurLabelRV = labelTextReactive noteDurLabel
 127   boxPackStart naBox noteDurBox PackNatural 0
 128   boxPackStart noteDurBox noteDurCombo PackNatural 0
 129   boxPackStart noteDurBox noteDurLabel PackNatural 0
 130
 131   -- Repeat count box
 132   rCountAdj <- adjustmentNew 1 0 100 1 1 0
 133   rCount <- spinButtonNew rCountAdj 1 0
 134   boxPackStart pieceBox rCount PackNatural 0
 135   let rCountRV = spinButtonValueIntReactive rCount
 136
 137   -- Side RV
 138   -- Carries the index of the tile to display and what to display.
 139   setRV <- newMCBMVar inertCell
 140
 141   reactiveValueOnCanRead noteDurRV $ do
 142     nDur <- reactiveValueRead noteDurRV
 143     oCell <- reactiveValueRead setRV
 144     let nCa :: Maybe NoteAttr
 145         nCa = fmap (\na -> na { naDur = nDur }) (getNAttr (cellAction oCell))
 146         nCell :: GUICell
 147         nCell = if isJust nCa
 148                 then oCell { cellAction =
 149                              setNAttr (fromJust nCa) (cellAction oCell) }
 150                 else oCell
 151     reactiveValueWriteOnNotEq setRV nCell
 152     fromMaybeM_ $ fmap (reactiveValueWrite noteDurLabelRV)
 153                        (lookup nDur symbolString)
 154
 155
 156   reactiveValueOnCanRead rCountRV $ do
 157     nRCount <- reactiveValueRead rCountRV
 158     oCell <- reactiveValueRead setRV
 159     let nCell = oCell { repeatCount = nRCount }
 160     reactiveValueWrite setRV nCell
 161
 162   reactiveValueOnCanRead slideComboRV $ do
 163     nSlide <- reactiveValueRead slideComboRV
 164     oCell <- reactiveValueRead setRV
 165     let nCa :: Maybe NoteAttr
 166         nCa = fmap (\na -> na { naOrn = (naOrn na) { ornSlide = nSlide } })
 167                    (getNAttr (cellAction oCell))
 168         nCell :: GUICell
 169         nCell = if isJust nCa
 170                 then oCell { cellAction =
 171                              setNAttr (fromJust nCa) (cellAction oCell)
 172                            }
 173                 else oCell
 174     reactiveValueWrite setRV nCell
 175
 176   reactiveValueOnCanRead artComboRV $ do
 177     nArt <- reactiveValueRead artComboRV
 178     oCell <- reactiveValueRead setRV
 179     let nCa :: Maybe NoteAttr
 180         nCa = fmap (\na -> na { naArt = nArt }) (getNAttr (cellAction oCell))
 181         nCell :: GUICell
 182         nCell = if isJust nCa
 183                 then oCell { cellAction =
 184                              setNAttr (fromJust nCa) (cellAction oCell) }
 185                 else oCell
 186     reactiveValueWrite setRV nCell
 187
 188   let hideNa :: IO ()
 189       hideNa = do widgetHide slideCombo
 190                   widgetHide artCombo
 191                   widgetShow rCount
 192                   widgetHideAll noteDurBox
 193       showNa :: IO ()
 194       showNa = do widgetShow slideCombo
 195                   widgetShow artCombo
 196                   widgetShow rCount
 197                   widgetShowAll noteDurBox
 198       updateNaBox :: GUICell -> IO ()
 199       updateNaBox GUICell { cellAction = act } = case act of
 200         Inert  -> hideNa
 201         Absorb -> hideNa
 202         _      -> showNa
 203
 204   reactiveValueOnCanRead setRV $ postGUIAsync $ do
 205     nCell <- reactiveValueRead setRV
 206     fromMaybeM_ (fmap (reactiveValueWriteOnNotEq artComboRV . naArt)
 207                       (getNAttr (cellAction nCell)))
 208     fromMaybeM_ (fmap (reactiveValueWriteOnNotEq slideComboRV
 209                        . ornSlide . naOrn)
 210                       (getNAttr (cellAction nCell)))
 211     reactiveValueWriteOnNotEq rCountRV $ repeatCount nCell
 212     fromMaybeM_ (fmap (reactiveValueWriteOnNotEq noteDurRV . naDur)
 213                       (getNAttr (cellAction nCell)))
 214     updateNaBox nCell
 215
 216   widgetShow pieceBox
 217   widgetShow naBox
 218   return (pieceBox,setRV)