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 <- newMCBMVar 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     reactiveValueWriteOnNotEq 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 $ do
 199     nCell <- reactiveValueRead setRV
 200     fromMaybeM_ (reactiveValueWriteOnNotEq artComboRV . naArt <$> getNAttr (cellAction nCell))
 201     fromMaybeM_ (reactiveValueWriteOnNotEq slideComboRV . ornSlide . naOrn <$> getNAttr (cellAction nCell))
 202     reactiveValueWriteOnNotEq rCountRV $ repeatCount nCell
 203     fromMaybeM_ (reactiveValueWriteOnNotEq noteDurRV . naDur <$> getNAttr (cellAction nCell))
 204     updateNaBox nCell
 205
 206 {-
 207   state <- newEmptyMVar
 208   boardOnPress board
 209     (\iPos -> liftIO $ do
 210         postGUIAsync $ void $ tryPutMVar state iPos
 211         return True
 212     )
 213   boardOnRelease board
 214     (\fPos -> do
 215         button <- eventButton
 216         liftIO $
 217           postGUIAsync $ do
 218             mp <- boardGetPiece fPos board
 219             mstate <- tryTakeMVar state
 220             when (fPos `elem` validArea && isJust mp) $ do
 221               let piece = snd $ fromJust mp
 222               when (button == RightButton && maybe False (== fPos) mstate) $
 223                 boardSetPiece fPos (BF.second rotateGUICell (Player,piece)) board
 224               nmp <- boardGetPiece fPos board
 225               when (button == LeftButton && isJust nmp) $ do
 226                 let nC = snd $ fromJust nmp
 227                 reactiveValueWrite setRV (fPos,nC)
 228                 fromMaybeM_ $ reactiveValueWrite artComboRV . naArt <$>
 229                   getNAttr (cellAction nC)
 230                 fromMaybeM_ $
 231                   reactiveValueWrite slideComboRV . ornSlide . naOrn <$> getNAttr (cellAction nC)
 232                 reactiveValueWrite rCountRV $ repeatCount nC
 233                 fromMaybeM_ $ reactiveValueWrite noteDurRV . naDur <$>
 234                   getNAttr (cellAction nC)
 235         return True
 236     )
 237
 238   reactiveValueOnCanRead setRV (reactiveValueRead setRV >>=  updateNaBox . snd)
 239
 240   widgetShow pieceBox
 241   widgetShow naBox
 242 -}
 243
 244   --setMCBMVar <- newMCBMVar =<< reactiveValueRead setRV
 245   --setMCBMVar =:= setRV
 246   widgetShow pieceBox
 247   widgetShow naBox
 248   return (pieceBox,setRV)