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
  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 True 0
  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   boxPackStart buttonBox buttonStop PackRepel 0
 163   buttonRecord <- buttonNewFromStock gtkMediaRecord
 164   boxPackStart buttonBox buttonRecord PackRepel 0
 165
 166   -- Board
 167   boardCont <- backgroundContainerNew
 168   game <- initGame
 169   guiBoard <- attachGameRules game
 170   --centerBoard <- alignmentNew 0.5 0.5 0 0
 171   containerAdd boardCont guiBoard
 172   --containerAdd boardCont centerBoard
 173   boxPackStart mainBox boardCont PackNatural 0
 174   --boxPackStart mainBox boardCont PackNatural 0
 175   ------------------------------------------------------------------------------
 176   boardQueue <- newCBMVarRW []
 177   -- Board setup
 178   layer <- reactiveValueRead layerRV
 179   tempo <- reactiveValueRead tempoRV
 180   (boardRV, phRV) <- initBoardRV guiBoard
 181   reactiveValueOnCanRead playRV
 182     (reactiveValueRead boardRV >>= reactiveValueWrite phRV . startHeads)
 183   board <- reactiveValueRead boardRV
 184   ph <- reactiveValueRead phRV
 185   (inBoard, outBoard) <- yampaReactiveDual (board, layer, ph, tempo) boardSF
 186   (splitE >>> fst) <^> outBoard >:> phRV
 187   --reactiveValueOnCanRead phRV $ boardRefresh guiBoard
 188   let inRV = liftR4 id
 189              boardRV layerRV phRV tempoRV
 190   clock <- mkClockRV 100
 191   --let inRV = onTick clock inRV
 192   inRV =:> inBoard
 193   reactiveValueOnCanRead outBoard $ do
 194     bq <- reactiveValueRead boardQueue
 195     ob <- reactiveValueRead $ liftR (event [] id <<< snd <<< splitE) outBoard
 196     reactiveValueWrite boardQueue (bq ++ ob)
 197   -- /!\ To be removed.
 198   --reactiveValueOnCanRead inRV (reactiveValueRead inRV >>= print . \(_,_,ph,_) -> ph)
 199   --reactiveValueOnCanRead outBoard (reactiveValueRead outBoard >>= print)
 200   reactiveValueOnCanRead phRV (reactiveValueRead phRV >>= print)
 201   putStrLn "Board started."
 202   -- Jack setup
 203   forkIO $ jackSetup tempoRV (constR 0) boardQueue
 204   widgetShowAll window
 205   onDestroy window mainQuit
 206   mainGUI
 207   --return ()