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