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
  27 import Control.Monad
  28 import Data.Ratio
  29
  30 floatConv :: (ReactiveValueReadWrite a b m,
  31               Real c, Real b, Fractional c, Fractional b) =>
  32              a -> ReactiveFieldReadWrite m c
  33 floatConv = liftRW $ bijection (realToFrac, realToFrac)
  34
  35 boardRVIO = newCBMVarRW $
  36     makeBoard [((0,0),  mkCell (ChDir True na1 NE)),
  37                ((1,1),  mkCellRpt (ChDir False na1 NW) 3),
  38                ((0,1),  mkCell (ChDir False na1 S))]
  39             {-makeBoard [((0,0), mkCell (ChDir True na1 N)),
  40                ((0,2), mkCellRpt (ChDir False na2 SE) 3),
  41                ((2,1), mkCell (ChDir False na1 SW)),
  42                ((1,1), mkCellRpt (ChDir False na1 N) 0) {- Skipped! -},
  43                ((0,4), mkCellRpt (ChDir True na1 N) (-1)) {- Rpt indef. -},
  44                ((0, -6), mkCell (ChDir True na1 N)),
  45                ((0, -2), mkCell (ChDir False na3 S) {- Silent -})]-}
  46
  47 na1 = NoteAttr {
  48           naArt = Accent13,
  49           naDur = 1 % 1,
  50           naOrn = Ornaments Nothing [] NoSlide
  51       }
  52
  53 na2 = NoteAttr {
  54           naArt = NoAccent,
  55           naDur = 1 % 1,
  56           naOrn = Ornaments Nothing [(10, MIDICVRnd)] SlideUp
  57       }
  58
  59 na3 = NoteAttr {
  60           naArt = Accent13,
  61           naDur = 0,
  62           naOrn = Ornaments Nothing [] NoSlide
  63       }
  64
  65
  66 bpb :: Int
  67 bpb = 4
  68
  69 newTempoRV :: IO (ReactiveFieldReadWrite IO Tempo)
  70 newTempoRV = newCBMVarRW 200
  71
  72 main :: IO ()
  73 main = do
  74   -- GUI
  75   initGUI
  76   window <- windowNew
  77   -- Main box
  78   mainBox <- hBoxNew True 0
  79   set window [ windowTitle := "Reactogon"
  80              --, windowDefaultWidth := 250
  81              --, windowDefaultHeight := 500
  82              , containerChild := mainBox
  83              , containerBorderWidth := 10
  84              ]
  85   windowMaximize window
  86
  87   settingsBox <- vBoxNew False 0
  88   boxPackEnd mainBox settingsBox PackNatural 0
  89   globalSettingsBox <- vBoxNew False 10
  90   boxPackStart settingsBox globalSettingsBox PackNatural 0
  91   tempoAdj <- adjustmentNew 120 40 200 1 1 1
  92   tempoLabel <- labelNew (Just "Tempo")
  93   boxPackStart globalSettingsBox tempoLabel PackNatural 0
  94   tempoScale <- hScaleNew tempoAdj
  95   boxPackStart globalSettingsBox tempoScale PackNatural 0
  96   scaleSetDigits tempoScale 0
  97   let tempoRV =
  98         bijection (floor, fromIntegral) `liftRW` scaleValueReactive tempoScale
  99   globalSep <- hSeparatorNew
 100   boxPackStart settingsBox globalSep PackNatural 0
 101
 102   layerSettingsBox <- hBoxNew True 10
 103   boxPackStart settingsBox layerSettingsBox PackNatural 0
 104
 105   layTempoBox <- hBoxNew False 10
 106   boxPackStart layerSettingsBox layTempoBox PackNatural 0
 107   layTempoLabel <- labelNew (Just "Layer tempo")
 108   labelSetAngle layTempoLabel 90
 109   boxPackStart layTempoBox layTempoLabel PackNatural 0
 110   layTempoAdj <- adjustmentNew 1 0 2 1 1 1
 111   layTempoScale <- vScaleNew layTempoAdj
 112   boxPackStart layTempoBox layTempoScale PackNatural 0
 113   laySep <- hSeparatorNew
 114
 115   strBox <- hBoxNew False 10
 116   boxPackStart layerSettingsBox strBox PackNatural 0
 117   strLabel <- labelNew (Just "Strength")
 118   labelSetAngle strLabel 90
 119   boxPackStart strBox strLabel PackNatural 0
 120   strAdj <- adjustmentNew 1 0 1 0.01 0.01 0
 121   layStrengthScale <- vScaleNew strAdj
 122   boxPackStart strBox layStrengthScale PackNatural 0
 123
 124   bpbBox <- vBoxNew False 10
 125   boxPackStart layerSettingsBox bpbBox PackNatural 0
 126   bpbLabel <- labelNew (Just "Beat per bar")
 127   labelSetLineWrap bpbLabel True
 128   boxPackStart bpbBox bpbLabel PackNatural 0
 129   bpbAdj <- adjustmentNew 4 1 16 1 1 0
 130   bpbButton <- spinButtonNew bpbAdj 1 0
 131   boxPackStart bpbBox bpbButton PackNatural 0
 132
 133   boxPackStart settingsBox laySep PackNatural 0
 134
 135   layPitchRV <- newCBMVarRW 1
 136   let layTempoRV = floatConv $ scaleValueReactive layTempoScale
 137       strengthRV = floatConv $  scaleValueReactive layStrengthScale
 138       bpbRV = spinButtonValueIntReactive bpbButton
 139       f1 Layer { relTempo = d
 140                , relPitch = p
 141                , strength = s
 142                , beatsPerBar = bpb
 143                } = (d,p,s,bpb)
 144       f2 (d,p,s,bpb) = Layer { relTempo = d
 145                              , relPitch = p
 146                              , strength = s
 147                              , beatsPerBar = bpb
 148                              }
 149       layerRV =
 150         liftRW4 (bijection (f1,f2)) layTempoRV layPitchRV strengthRV bpbRV
 151
 152
 153   buttonBox <- hBoxNew True 10
 154   boxPackEnd settingsBox buttonBox PackNatural 0
 155   buttonPlay <- buttonNewFromStock gtkMediaPlay
 156   boxPackStart buttonBox buttonPlay PackRepel 0
 157   buttonPause <- buttonNewFromStock gtkMediaPause
 158   boxPackStart buttonBox buttonPause PackRepel 0
 159   buttonStop <- buttonNewFromStock gtkMediaStop
 160   boxPackStart buttonBox buttonStop PackRepel 0
 161   buttonRecord <- buttonNewFromStock gtkMediaRecord
 162   boxPackStart buttonBox buttonRecord PackRepel 0
 163
 164   -- Board
 165   boardCont <- backgroundContainerNew
 166   game <- initGame
 167   board <- attachGameRules game
 168   forkIO $ forever $ do
 169     threadDelay (10^6)
 170     p <- boardGetPiece (0,-10) board
 171     print p
 172   --centerBoard <- alignmentNew 0.5 0.5 0 0
 173   containerAdd boardCont board
 174   --containerAdd boardCont centerBoard
 175   boxPackStart mainBox boardCont PackNatural 0
 176   --boxPackStart mainBox boardCont PackNatural 0
 177   ------------------------------------------------------------------------------
 178   boardQueue <- newCBMVarRW []
 179   -- Board setup
 180   layer <- reactiveValueRead layerRV
 181   tempo <- reactiveValueRead tempoRV
 182   boardRV <- boardRVIO
 183   board <- reactiveValueRead boardRV
 184   (inBoard, outBoard) <- yampaReactiveDual (board, layer, tempo)
 185                          (boardSF $ startHeads board)
 186   let inRV = liftRW2 (bijection (\(x,y,z) -> (x,(y,z)), \(x,(y,z)) -> (x,y,z)))
 187              boardRV $ pairRW layerRV tempoRV
 188   clock <- mkClockRV 100
 189   clock ^:> inRV
 190   inRV =:> inBoard
 191   --reactiveValueOnCanRead outBoard (reactiveValueRead outBoard >>= print . ("Board out " ++) . show)
 192   reactiveValueOnCanRead outBoard $ do
 193     bq <- reactiveValueRead boardQueue
 194     ob <- reactiveValueRead $ liftR (event [] id) outBoard
 195     reactiveValueWrite boardQueue (bq ++ ob)
 196   -- /!\ To be removed.
 197   --reactiveValueOnCanRead outBoard (reactiveValueRead outBoard >>= print)
 198   putStrLn "Board started."
 199   -- Jack setup
 200   forkIO $ jackSetup tempoRV (constR 0) boardQueue
 201   widgetShowAll window
 202   onDestroy window mainQuit
 203   mainGUI
 204   --return ()