RMCA/Main.hs

   1 {-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables #-}
   2
   3 module Main where
   4
   5 import           Control.Concurrent
   6 import           Data.Array.IO
   7 import           Data.Array.MArray
   8 import           Data.ReactiveValue
   9 import           FRP.Yampa
  10 import           Game.Board.BasicTurnGame
  11 import           Graphics.UI.Gtk
  12 import           Graphics.UI.Gtk.Board.BoardLink
  13 import           Graphics.UI.Gtk.Board.TiledBoard
  14 import qualified Graphics.UI.Gtk.Board.TiledBoard           as BIO
  15 import           Graphics.UI.Gtk.Layout.BackgroundContainer
  16 import           Graphics.UI.Gtk.Reactive
  17 import           Hails.Yampa
  18 import           RMCA.Auxiliary.Concurrent
  19 import           RMCA.Auxiliary.RV
  20 import           RMCA.Global.Clock
  21 import           RMCA.GUI.Board
  22 import           RMCA.GUI.Buttons
  23 import           RMCA.Layer.Board
  24 import           RMCA.Layer.Layer
  25 import           RMCA.Semantics
  26 import           RMCA.Translator.Jack
  27 import           RMCA.Translator.Message
  28 import           RMCA.Translator.Translator
  29
  30
  31 import           Control.Monad
  32 import           Data.Ratio
  33
  34 floatConv :: (ReactiveValueReadWrite a b m,
  35               Real c, Real b, Fractional c, Fractional b) =>
  36              a -> ReactiveFieldReadWrite m c
  37 floatConv = liftRW $ bijection (realToFrac, realToFrac)
  38 {-
  39 boardRVIO = newCBMVarRW $
  40     makeBoard [((0,0),  mkCell (ChDir True na1 NE)),
  41                ((1,1),  mkCellRpt (ChDir False na1 NW) 3),
  42                ((0,1),  mkCell (ChDir False na1 S))]
  43             {-makeBoard [((0,0), mkCell (ChDir True na1 N)),
  44                ((0,2), mkCellRpt (ChDir False na2 SE) 3),
  45                ((2,1), mkCell (ChDir False na1 SW)),
  46                ((1,1), mkCellRpt (ChDir False na1 N) 0) {- Skipped! -},
  47                ((0,4), mkCellRpt (ChDir True na1 N) (-1)) {- Rpt indef. -},
  48                ((0, -6), mkCell (ChDir True na1 N)),
  49                ((0, -2), mkCell (ChDir False na3 S) {- Silent -})]-}
  50
  51 na1 = NoteAttr {
  52           naArt = Accent13,
  53           naDur = 1 % 1,
  54           naOrn = Ornaments Nothing [] NoSlide
  55       }
  56
  57 na2 = NoteAttr {
  58           naArt = NoAccent,
  59           naDur = 1 % 1,
  60           naOrn = Ornaments Nothing [(10, MIDICVRnd)] SlideUp
  61       }
  62
  63 na3 = NoteAttr {
  64           naArt = Accent13,
  65           naDur = 0,
  66           naOrn = Ornaments Nothing [] NoSlide
  67       }
  68
  69
  70 bpb :: Int
  71 bpb = 4
  72 -}
  73
  74 main :: IO ()
  75 main = do
  76   -- GUI
  77   initGUI
  78   window <- windowNew
  79   -- Main box
  80   mainBox <- hBoxNew False 10
  81   set window [ windowTitle := "Reactogon"
  82              --, windowDefaultWidth := 250
  83              --, windowDefaultHeight := 500
  84              , containerChild := mainBox
  85              , containerBorderWidth := 10
  86              ]
  87   windowMaximize window
  88
  89   settingsBox <- vBoxNew False 0
  90   boxPackEnd mainBox settingsBox PackNatural 0
  91   globalSettingsBox <- vBoxNew False 10
  92   boxPackStart settingsBox globalSettingsBox PackNatural 0
  93   tempoAdj <- adjustmentNew 120 40 200 1 1 1
  94   tempoLabel <- labelNew (Just "Tempo")
  95   boxPackStart globalSettingsBox tempoLabel PackNatural 0
  96   tempoScale <- hScaleNew tempoAdj
  97   boxPackStart globalSettingsBox tempoScale PackNatural 0
  98   scaleSetDigits tempoScale 0
  99   let tempoRV =
 100         bijection (floor, fromIntegral) `liftRW` scaleValueReactive tempoScale
 101   globalSep <- hSeparatorNew
 102   boxPackStart settingsBox globalSep PackNatural 0
 103
 104   layerSettingsBox <- hBoxNew True 10
 105   boxPackStart settingsBox layerSettingsBox PackNatural 0
 106
 107   layTempoBox <- hBoxNew False 10
 108   boxPackStart layerSettingsBox layTempoBox PackNatural 0
 109   layTempoLabel <- labelNew (Just "Layer tempo")
 110   labelSetAngle layTempoLabel 90
 111   boxPackStart layTempoBox layTempoLabel PackNatural 0
 112   layTempoAdj <- adjustmentNew 1 0 2 1 1 1
 113   layTempoScale <- vScaleNew layTempoAdj
 114   boxPackStart layTempoBox layTempoScale PackNatural 0
 115   laySep <- hSeparatorNew
 116
 117   strBox <- hBoxNew False 10
 118   boxPackStart layerSettingsBox strBox PackNatural 0
 119   strLabel <- labelNew (Just "Strength")
 120   labelSetAngle strLabel 90
 121   boxPackStart strBox strLabel PackNatural 0
 122   strAdj <- adjustmentNew 1 0 1 0.01 0.01 0
 123   layStrengthScale <- vScaleNew strAdj
 124   boxPackStart strBox layStrengthScale PackNatural 0
 125
 126   bpbBox <- vBoxNew False 10
 127   boxPackStart layerSettingsBox bpbBox PackNatural 0
 128   bpbLabel <- labelNew (Just "Beat per bar")
 129   labelSetLineWrap bpbLabel True
 130   boxPackStart bpbBox bpbLabel PackNatural 0
 131   bpbAdj <- adjustmentNew 4 1 16 1 1 0
 132   bpbButton <- spinButtonNew bpbAdj 1 0
 133   boxPackStart bpbBox bpbButton PackNatural 0
 134
 135   boxPackStart settingsBox laySep PackNatural 0
 136
 137   layPitchRV <- newCBMVarRW 1
 138   let layTempoRV = floatConv $ scaleValueReactive layTempoScale
 139       strengthRV = floatConv $  scaleValueReactive layStrengthScale
 140       bpbRV = spinButtonValueIntReactive bpbButton
 141       f1 Layer { relTempo = d
 142                , relPitch = p
 143                , strength = s
 144                , beatsPerBar = bpb
 145                } = (d,p,s,bpb)
 146       f2 (d,p,s,bpb) = Layer { relTempo = d
 147                              , relPitch = p
 148                              , strength = s
 149                              , beatsPerBar = bpb
 150                              }
 151       layerRV =
 152         liftRW4 (bijection (f1,f2)) layTempoRV layPitchRV strengthRV bpbRV
 153
 154   buttonBox <- hBoxNew True 10
 155   boxPackEnd settingsBox buttonBox PackNatural 0
 156   buttonPlay <- buttonNewFromStock gtkMediaPlay
 157   let playRV = buttonActivateField buttonPlay
 158   boxPackStart buttonBox buttonPlay PackRepel 0
 159   buttonPause <- buttonNewFromStock gtkMediaPause
 160   boxPackStart buttonBox buttonPause PackRepel 0
 161   buttonStop <- buttonNewFromStock gtkMediaStop
 162   let stopRV = buttonActivateField buttonStop
 163   boxPackStart buttonBox buttonStop PackRepel 0
 164   buttonRecord <- buttonNewFromStock gtkMediaRecord
 165   boxPackStart buttonBox buttonRecord PackRepel 0
 166
 167   -- Board
 168   boardCont <- backgroundContainerNew
 169   game <- initGame
 170   guiBoard <- attachGameRules game
 171   centerBoard <- alignmentNew 0.5 0.5 0 0
 172   containerAdd centerBoard guiBoard
 173   containerAdd boardCont centerBoard
 174   boxPackStart mainBox boardCont PackNatural 0
 175   --boxPackStart mainBox boardCont PackNatural 0
 176   ------------------------------------------------------------------------------
 177   boardQueue <- newCBMVarRW []
 178   -- Board setup
 179   layer <- reactiveValueRead layerRV
 180   tempo <- reactiveValueRead tempoRV
 181   (boardRV, phRV) <- initBoardRV guiBoard
 182   clickHandling guiBoard
 183   reactiveValueOnCanRead playRV
 184     (reactiveValueRead boardRV >>= reactiveValueWrite phRV . startHeads)
 185   reactiveValueOnCanRead stopRV $ reactiveValueWrite phRV []
 186   board <- reactiveValueRead boardRV
 187   ph <- reactiveValueRead phRV
 188   (inBoard, outBoard) <- yampaReactiveDual (board, layer, ph, tempo) boardSF
 189   let inRV = liftR4 id
 190              boardRV layerRV phRV tempoRV
 191   clock <- mkClockRV 100
 192   --let inRV = onTick clock inRV
 193   inRV =:> inBoard
 194   reactiveValueOnCanRead outBoard $ do
 195     bq <- reactiveValueRead boardQueue
 196     ob <- reactiveValueRead $ liftR (event [] id <<< snd <<< splitE) outBoard
 197     reactiveValueWrite boardQueue (bq ++ ob)
 198   -- This needs to be set last otherwise phRV is written to, so
 199   -- inBoard is written to and the notes don't get played. There
 200   -- supposedly is no guaranty of order but apparently there is…
 201   (fst <$>) <^> outBoard >:> phRV
 202   putStrLn "Board started."
 203   -- Jack setup
 204   forkIO $ jackSetup tempoRV (constR 0) boardQueue
 205   widgetShowAll window
 206   onDestroy window mainQuit
 207   mainGUI
 208   --return ()