src/RMCA/GUI/NoteSettings.hs

   1 {-# LANGUAGE ScopedTypeVariables, TupleSections #-}
   2
   3 module RMCA.GUI.NoteSettings where
   4
   5 import           Control.Concurrent.MVar
   6 import           Control.Monad
   7 import           Control.Monad.IO.Class
   8 import           Data.Array
   9 import qualified Data.Bifunctor                   as BF
  10 import           Data.List
  11 import           Data.Maybe
  12 import           Data.Ord
  13 import           Data.Ratio
  14 import           Data.ReactiveValue
  15 import           Data.String
  16 import           Data.Tuple
  17 import           Graphics.UI.Gtk                  hiding (Action)
  18 import           Graphics.UI.Gtk.Board.TiledBoard hiding (Board)
  19 import           Graphics.UI.Gtk.Reactive
  20 import           RMCA.Auxiliary.RV
  21 import           RMCA.GUI.Board
  22 import           RMCA.Semantics
  23
  24 fromMaybeM_ :: (Monad m) => Maybe (m ()) -> m ()
  25 fromMaybeM_ = fromMaybe (return ())
  26
  27 setNAttr :: NoteAttr -> Action -> Action
  28 setNAttr _ Inert = Inert
  29 setNAttr _ Absorb = Absorb
  30 setNAttr na (Stop _) = Stop na
  31 setNAttr na (ChDir b _ dir) = ChDir b na dir
  32 setNAttr na (Split _) = Split na
  33
  34 getNAttr :: Action -> Maybe NoteAttr
  35 getNAttr Inert = Nothing
  36 getNAttr Absorb = Nothing
  37 getNAttr (Stop na) = Just na
  38 getNAttr (ChDir _ na _) = Just na
  39 getNAttr (Split na) = Just na
  40
  41 noteList :: [(String, Duration)]
  42 noteList = sortBy (comparing snd)
  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 clickHandling :: Array Pos (ReactiveFieldWrite IO GUICell)
  58               -> IOBoard -> VBox -> IO VBox
  59 clickHandling pieceArrRV board pieceBox = do
  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 = fromMaybe NoAccent $ lookup i $ map swap artIndex
  71       artToIndex a = fromMaybe (-1) $ lookup a artIndex
  72       artComboRV = bijection (indexToArt,artToIndex) `liftRW`
  73                    comboBoxIndexRV artCombo
  74
  75   -- Slide box
  76   slideCombo <- comboBoxNewText
  77   slideIndex <- mapM (\sli -> do i <- comboBoxAppendText slideCombo
  78                                       (fromString $ show sli)
  79                                  return (sli,i)) [NoSlide ..]
  80   comboBoxSetActive slideCombo 0
  81   boxPackStart naBox slideCombo PackNatural 10
  82   let indexToSlide i = fromMaybe NoSlide $ lookup i $ map swap slideIndex
  83       slideToIndex s = fromMaybe (-1) $ lookup s slideIndex
  84       slideComboRV = bijection (indexToSlide,slideToIndex) `liftRW`
  85                      comboBoxIndexRV slideCombo
  86
  87   -- Note duration box
  88   noteDurCombo <- comboBoxNewText
  89   noteDurIndex <- mapM (\(str,dur) -> do i <- comboBoxAppendText noteDurCombo
  90                                               (fromString str)
  91                                          return (dur,i)) noteList
  92   comboBoxSetActive noteDurCombo 0
  93   boxPackStart naBox noteDurCombo PackNatural 10
  94   let indexToDur i = fromMaybe (1 % 4) $ lookup i $ map swap noteDurIndex
  95       durToIndex d = fromMaybe 0 $ lookup d noteDurIndex
  96       noteDurRV = bijection (indexToDur, durToIndex) `liftRW`
  97                   comboBoxIndexRV noteDurCombo
  98
  99   -- Repeat count box
 100   rCountAdj <- adjustmentNew 1 0 10 1 1 0
 101   rCount <- spinButtonNew rCountAdj 1 0
 102   boxPackStart pieceBox rCount PackNatural 10
 103   let rCountRV = spinButtonValueIntReactive rCount
 104
 105   -- Side RV
 106   -- Carries the index of the tile to display and what to display.
 107   setRV <- newCBMVarRW ((0,0),inertCell)
 108
 109   reactiveValueOnCanRead noteDurRV $ do
 110     nDur <- reactiveValueRead noteDurRV
 111     (i,oCell) <- reactiveValueRead setRV
 112     let nCa :: Maybe NoteAttr
 113         nCa = (\na -> na { naDur = nDur }) <$> getNAttr (cellAction oCell)
 114         nCell :: GUICell
 115         nCell = if isJust nCa
 116                 then oCell { cellAction =
 117                              setNAttr (fromJust nCa) (cellAction oCell) }
 118                 else oCell
 119     reactiveValueWrite setRV (i,nCell)
 120     reactiveValueWrite (pieceArrRV ! i) nCell
 121
 122
 123   reactiveValueOnCanRead rCountRV $ do
 124     nRCount <- reactiveValueRead rCountRV
 125     (i,oCell) <- reactiveValueRead setRV
 126     let nCell = oCell { repeatCount = nRCount }
 127     reactiveValueWrite setRV (i,nCell)
 128     reactiveValueWrite (pieceArrRV ! i) nCell
 129
 130   reactiveValueOnCanRead slideComboRV $ do
 131     nSlide <- reactiveValueRead slideComboRV
 132     (i,oCell) <- reactiveValueRead setRV
 133     let nCa :: Maybe NoteAttr
 134         nCa = (\na -> na { naOrn = (naOrn na) { ornSlide = nSlide } }) <$>
 135               getNAttr (cellAction oCell)
 136         nCell :: GUICell
 137         nCell = if isJust nCa
 138                 then oCell { cellAction =
 139                              setNAttr (fromJust nCa) (cellAction oCell)
 140                            }
 141                 else oCell
 142     reactiveValueWrite setRV (i,nCell)
 143     reactiveValueWrite (pieceArrRV ! i) nCell
 144
 145   reactiveValueOnCanRead artComboRV $ do
 146     --nArt <- reactiveValueRead artComboRV
 147     (i,oCell) <- reactiveValueRead setRV
 148     let nCa :: Maybe NoteAttr
 149         nCa = getNAttr $ cellAction oCell
 150         nCell :: GUICell
 151         nCell = if isJust nCa
 152                 then oCell { cellAction =
 153                              setNAttr (fromJust nCa) (cellAction oCell) }
 154                 else oCell
 155     reactiveValueWrite setRV (i,nCell)
 156     reactiveValueWrite (pieceArrRV ! i) nCell
 157
 158   let hideNa :: IO ()
 159       hideNa = do widgetHide slideCombo
 160                   widgetHide artCombo
 161                   widgetShow rCount
 162                   widgetHide noteDurCombo
 163       showNa :: IO ()
 164       showNa = do widgetShow slideCombo
 165                   widgetShow artCombo
 166                   widgetShow rCount
 167                   widgetShow noteDurCombo
 168       updateNaBox :: GUICell -> IO ()
 169       updateNaBox GUICell { cellAction = act } = case act of
 170         Inert -> hideNa
 171         Absorb -> hideNa
 172         _ -> showNa
 173
 174   state <- newEmptyMVar
 175   boardOnPress board
 176     (\iPos -> liftIO $ do
 177         postGUIAsync $ void $ tryPutMVar state iPos
 178         return True
 179     )
 180   boardOnRelease board
 181     (\fPos -> liftIO $ do
 182         postGUIAsync $ do
 183           mp <- boardGetPiece fPos board
 184           mstate <- tryTakeMVar state
 185           when (fPos `elem` validArea && isJust mp) $ do
 186             let piece = snd $ fromJust mp
 187             when (maybe False (== fPos) mstate) $
 188               boardSetPiece fPos (BF.second rotateGUICell (Player,piece)) board
 189             nmp <- boardGetPiece fPos board
 190             print nmp
 191             when (isJust nmp) $ do
 192               let nC = snd $ fromJust nmp
 193               reactiveValueWrite setRV (fPos,nC)
 194               fromMaybeM_ $ reactiveValueWrite artComboRV . naArt <$>
 195                 getNAttr (cellAction nC)
 196               fromMaybeM_ $
 197                 reactiveValueWrite slideComboRV . ornSlide . naOrn <$> getNAttr (cellAction nC)
 198               reactiveValueWrite rCountRV $ repeatCount nC
 199               fromMaybeM_ $ reactiveValueWrite noteDurRV . naDur <$>
 200                 getNAttr (cellAction nC)
 201         return True
 202     )
 203
 204   reactiveValueOnCanRead setRV (reactiveValueRead setRV >>=  updateNaBox . snd)
 205
 206   widgetShow pieceBox
 207   widgetShow naBox
 208   return pieceBox