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