src/RMCA/GUI/NoteSettings.hs

   1 {-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, ScopedTypeVariables,
   2              TupleSections #-}
   3
   4 module RMCA.GUI.NoteSettings where
   5
   6 import           Control.Concurrent.MVar
   7 import           Control.Monad
   8 import           Control.Monad.IO.Class
   9 import           Data.Array
  10 import qualified Data.Bifunctor                   as BF
  11 import           Data.List
  12 import           Data.Maybe
  13 import           Data.Ord
  14 import           Data.Ratio
  15 import           Data.ReactiveValue
  16 import           Data.String
  17 import           Data.Tuple
  18 import           Graphics.UI.Gtk                  hiding (Action)
  19 import           Graphics.UI.Gtk.Board.TiledBoard hiding (Board)
  20 import           Graphics.UI.Gtk.Reactive
  21 import           RMCA.Auxiliary.RV
  22 import           RMCA.GUI.Board
  23 import           RMCA.Semantics
  24
  25 fromMaybeM_ :: (Monad m) => Maybe (m ()) -> m ()
  26 fromMaybeM_ = fromMaybe (return ())
  27
  28 setNAttr :: NoteAttr -> Action -> Action
  29 setNAttr _ Inert = Inert
  30 setNAttr _ Absorb = Absorb
  31 setNAttr na (Stop _) = Stop na
  32 setNAttr na (ChDir b _ dir) = ChDir b na dir
  33 setNAttr na (Split _) = Split na
  34
  35 getNAttr :: Action -> Maybe NoteAttr
  36 getNAttr Inert = Nothing
  37 getNAttr Absorb = Nothing
  38 getNAttr (Stop na) = Just na
  39 getNAttr (ChDir _ na _) = Just na
  40 getNAttr (Split na) = Just na
  41
  42 symbolString :: [(Duration,String)]
  43 symbolString = map (\(_,y,z) -> (z,y)) noteSymbList
  44
  45 noteList :: [(String,Duration)]
  46 noteList = map (\(x,_,y) -> (x,y)) noteSymbList
  47
  48 noteSymbList :: [(String, String, Duration)]
  49 noteSymbList = sortBy (comparing (\(_,_,x) -> x))
  50                [ ("♩", "Quarter note", 1 % 4)
  51                , ("♪", "Eighth note ", 1 % 8)
  52                , ("𝅗𝅥", "Half note", 1 % 2)
  53                , ("𝅘𝅥𝅯", "Sixteenth note", 1 % 16)
  54                , ("𝅝", "Whole note", 1)
  55                ]
  56
  57 comboBoxIndexRV :: (ComboBoxClass box) =>
  58                    box -> ReactiveFieldReadWrite IO Int
  59 comboBoxIndexRV box = ReactiveFieldReadWrite setter getter notifier
  60   where getter = comboBoxGetActive box
  61         setter = comboBoxSetActive box
  62         notifier = void . on box changed
  63
  64 clickHandling :: (ReactiveValueWrite cell GUICell IO) =>
  65                  Array Pos cell
  66               -> IOBoard -> VBox -> IO VBox
  67 clickHandling pieceArrRV board pieceBox = do
  68   naBox <- vBoxNew False 10
  69   boxPackStart pieceBox naBox PackNatural 10
  70
  71   -- Articulation box
  72   artCombo <- comboBoxNewText
  73   artIndex <- mapM (\art -> do i <- comboBoxAppendText artCombo
  74                                     (fromString $ show art)
  75                                return (art,i)) [NoAccent ..]
  76   comboBoxSetActive artCombo 0
  77   boxPackStart naBox artCombo PackNatural 10
  78   let indexToArt i = case lookup i $ map swap artIndex of
  79         Nothing -> error "In indexToArt: failed \
  80                          \to find the selected articulation."
  81         Just art -> art
  82       artToIndex a = case lookup a artIndex of
  83         Nothing -> error "In artToIndex: failed \
  84                          \to find the correct index for the articulation."
  85         Just i -> i
  86       artComboRV = bijection (indexToArt,artToIndex) `liftRW`
  87                    comboBoxIndexRV artCombo
  88
  89   -- Slide box
  90   slideCombo <- comboBoxNewText
  91   slideIndex <- mapM (\sli -> do i <- comboBoxAppendText slideCombo
  92                                       (fromString $ show sli)
  93                                  return (sli,i)) [NoSlide ..]
  94   comboBoxSetActive slideCombo 0
  95   boxPackStart naBox slideCombo PackNatural 10
  96   let indexToSlide i = case lookup i $ map swap slideIndex of
  97         Nothing -> error "In indexToSlide: failed\
  98                          \to find the correct slide for the selected index."
  99         Just sli -> sli
 100       slideToIndex s = case lookup s slideIndex of
 101         Nothing -> error "In slideToIndex: failed\
 102                          \to find the correct index for the slide."
 103         Just i -> i
 104       slideComboRV = bijection (indexToSlide,slideToIndex) `liftRW`
 105                      comboBoxIndexRV slideCombo
 106
 107   -- Note duration box
 108   noteDurBox <- hBoxNew False 10
 109   noteDurCombo <- comboBoxNewText
 110   noteDurIndex <- mapM (\(str,dur) -> do i <- comboBoxAppendText noteDurCombo
 111                                               (fromString str)
 112                                          return (dur,i)) noteList
 113   comboBoxSetActive noteDurCombo 0
 114   let indexToDur i = case lookup i $ map swap noteDurIndex of
 115         Nothing -> error "In indexToDur: failed\
 116                          \to find the correct duration for the selected index."
 117         Just dur -> dur
 118       durToIndex d = case lookup d noteDurIndex of
 119         Nothing -> error "In durToIndex: failed\
 120                          \to find the correct index for the duration."
 121         Just i -> i
 122       noteDurRV = bijection (indexToDur, durToIndex) `liftRW`
 123                   comboBoxIndexRV noteDurCombo
 124   noteDurLabel <- labelNew =<< (\d -> lookup d symbolString) <$> reactiveValueRead noteDurRV
 125   let noteDurLabelRV = labelTextReactive noteDurLabel
 126   boxPackStart naBox noteDurBox PackNatural 10
 127   boxPackStart noteDurBox noteDurCombo PackNatural 10
 128   boxPackStart noteDurBox noteDurLabel PackNatural 10
 129
 130   -- Repeat count box
 131   rCountAdj <- adjustmentNew 1 0 100 1 1 0
 132   rCount <- spinButtonNew rCountAdj 1 0
 133   boxPackStart pieceBox rCount PackNatural 10
 134   let rCountRV = spinButtonValueIntReactive rCount
 135
 136   -- Side RV
 137   -- Carries the index of the tile to display and what to display.
 138   setRV <- newCBMVarRW ((0,0),inertCell)
 139
 140   reactiveValueOnCanRead noteDurRV $ do
 141     nDur <- reactiveValueRead noteDurRV
 142     (i,oCell) <- reactiveValueRead setRV
 143     let nCa :: Maybe NoteAttr
 144         nCa = (\na -> na { naDur = nDur }) <$> getNAttr (cellAction oCell)
 145         nCell :: GUICell
 146         nCell = if isJust nCa
 147                 then oCell { cellAction =
 148                              setNAttr (fromJust nCa) (cellAction oCell) }
 149                 else oCell
 150     reactiveValueWrite setRV (i,nCell)
 151     fromMaybeM_ $ reactiveValueWrite noteDurLabelRV <$> lookup nDur symbolString
 152     reactiveValueWrite (pieceArrRV ! i) nCell
 153
 154
 155   reactiveValueOnCanRead rCountRV $ do
 156     nRCount <- reactiveValueRead rCountRV
 157     (i,oCell) <- reactiveValueRead setRV
 158     let nCell = oCell { repeatCount = nRCount }
 159     reactiveValueWrite setRV (i,nCell)
 160     reactiveValueWrite (pieceArrRV ! i) nCell
 161
 162   reactiveValueOnCanRead slideComboRV $ do
 163     nSlide <- reactiveValueRead slideComboRV
 164     (i,oCell) <- reactiveValueRead setRV
 165     let nCa :: Maybe NoteAttr
 166         nCa = (\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 (i,nCell)
 175     reactiveValueWrite (pieceArrRV ! i) nCell
 176
 177   reactiveValueOnCanRead artComboRV $ do
 178     nArt <- reactiveValueRead artComboRV
 179     (i,oCell) <- reactiveValueRead setRV
 180     let nCa :: Maybe NoteAttr
 181         nCa = (\na -> na { naArt = nArt }) <$> getNAttr (cellAction oCell)
 182         nCell :: GUICell
 183         nCell = if isJust nCa
 184                 then oCell { cellAction =
 185                              setNAttr (fromJust nCa) (cellAction oCell) }
 186                 else oCell
 187     reactiveValueWrite setRV (i,nCell)
 188     reactiveValueWrite (pieceArrRV ! i) nCell
 189
 190   let hideNa :: IO ()
 191       hideNa = do widgetHide slideCombo
 192                   widgetHide artCombo
 193                   widgetShow rCount
 194                   widgetHideAll noteDurBox
 195       showNa :: IO ()
 196       showNa = do widgetShow slideCombo
 197                   widgetShow artCombo
 198                   widgetShow rCount
 199                   widgetShowAll noteDurBox
 200       updateNaBox :: GUICell -> IO ()
 201       updateNaBox GUICell { cellAction = act } = case act of
 202         Inert -> hideNa
 203         Absorb -> hideNa
 204         _ -> showNa
 205
 206   state <- newEmptyMVar
 207   boardOnPress board
 208     (\iPos -> liftIO $ do
 209         postGUIAsync $ void $ tryPutMVar state iPos
 210         return True
 211     )
 212   boardOnRelease board
 213     (\fPos -> do
 214         button <- eventButton
 215         liftIO $
 216           postGUIAsync $ do
 217             mp <- boardGetPiece fPos board
 218             mstate <- tryTakeMVar state
 219             when (fPos `elem` validArea && isJust mp) $ do
 220               let piece = snd $ fromJust mp
 221               when (button == RightButton && maybe False (== fPos) mstate) $
 222                 boardSetPiece fPos (BF.second rotateGUICell (Player,piece)) board
 223               nmp <- boardGetPiece fPos board
 224               --print nmp
 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   return pieceBox