RMCA/Main.hs

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