src/RMCA/Main.hs

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