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