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 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   reactiveValueOnCanRead playRV
 183     (reactiveValueRead boardRV >>= reactiveValueWrite phRV . startHeads)
 184   reactiveValueOnCanRead stopRV $ reactiveValueWrite phRV []
 185   board <- reactiveValueRead boardRV
 186   ph <- reactiveValueRead phRV
 187   (inBoard, outBoard) <- yampaReactiveDual (board, layer, ph, tempo) boardSF
 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   -- This needs to be set last otherwise phRV is written to, so
 198   -- inBoard is written to and the notes don't get played. There
 199   -- supposedly is no guaranty of order but apparently there is…
 200   (fst <$>) <^> outBoard >:> phRV
 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 ()