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