src/RMCA/Main.hs

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