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