src/RMCA/GUI/NoteSettings.hs

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