src/RMCA/GUI/NoteSettings.hs

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