Commit da23b70d authored by Guerric Chupin's avatar Guerric Chupin

Basic tab system but completely not very well linked to the internal machine…

parent f12cedf3
......@@ -29,4 +29,8 @@ html/
*.txt
/.cabal-sandbox/
/.ghci
/lol.hs
\ No newline at end of file
/lol.hs
*.aux
*.hp
*.prof
*.ps
\ No newline at end of file
......@@ -4,6 +4,7 @@ module RMCA.Auxiliary where
import Control.Monad
import Data.CBMVar
import Data.Fixed
import Data.Maybe
import Data.ReactiveValue
import FRP.Yampa
......@@ -21,6 +22,22 @@ bound (min, max) x
fromMaybeM_ :: (Monad m) => Maybe (m ()) -> m ()
fromMaybeM_ = fromMaybe (return ())
safeHead :: [a] -> Maybe a
safeHead [] = Nothing
safeHead (x:_) = Just x
safeTail :: [a] -> [a]
safeTail [] = []
safeTail (_:xs) = xs
maybeToEvent :: Maybe a -> Event a
maybeToEvent Nothing = NoEvent
maybeToEvent (Just x) = Event x
eventToMaybe :: Event a -> Maybe a
eventToMaybe NoEvent = Nothing
eventToMaybe (Event x) = Just x
--------------------------------------------------------------------------------
-- FRP
--------------------------------------------------------------------------------
......@@ -52,12 +69,11 @@ onChange = proc x -> do
returnA -< makeEvent x x'
varFreqSine :: SF DTime Double
varFreqSine = sin ^<< (2*pi*) ^<< integral <<^ (1/)
varFreqSine = sin ^<< (2*pi*) ^<< (`mod'` 1) ^<< integral <<^ (1/)
repeatedlyS :: a -> SF DTime (Event a)
repeatedlyS x = proc dt -> do
(sw,sw') <- (identity &&& stepBack) <<< varFreqSine -< 2*dt
edgeTag x <<^ maybe True (< 0) -< (*) <$> return sw <*> sw'
repeatedlyS x = edgeBy (\a b -> if a * b < 0 then Just x else Nothing) 0
<<< varFreqSine <<^ (2*)
-- Similar to onChange but contains its initial value in the first
-- event.
......
......@@ -21,8 +21,6 @@ import Paths_RMCA
import RMCA.Global.Clock
import RMCA.Semantics
import Debug.Trace
data GUICell = GUICell { cellAction :: Action
, repeatCount :: Int
, asPh :: Bool
......
......@@ -5,25 +5,7 @@ module RMCA.GUI.Buttons where
import Data.ReactiveValue
import Graphics.UI.Gtk
import Graphics.UI.Gtk.Reactive
import System.Glib
gtkMediaPlay :: DefaultGlibString
gtkMediaPlay = stringToGlib "gtk-media-play"
gtkMediaStop :: DefaultGlibString
gtkMediaStop = stringToGlib "gtk-media-stop"
gtkMediaPause :: DefaultGlibString
gtkMediaPause = stringToGlib "gtk-media-pause"
gtkMediaRecord :: DefaultGlibString
gtkMediaRecord = stringToGlib "gtk-media-record"
gtkMediaSave :: DefaultGlibString
gtkMediaSave = stringToGlib "gtk-save"
gtkMediaOpen :: DefaultGlibString
gtkMediaOpen = stringToGlib "gtk-open"
import RMCA.GUI.StockId
buttonNewFromStockWithLabel :: StockId -> String -> IO Button
buttonNewFromStockWithLabel s l = do
......@@ -57,20 +39,33 @@ getButtons :: IO ( VBox
, ReactiveFieldRead IO Bool
, ReactiveFieldRead IO ()
, ReactiveFieldRead IO ()
, ReactiveFieldRead IO ()
, ReactiveFieldRead IO ()
)
getButtons = do
buttonBox <- vBoxNew False 10
buttonBoxTop <- hBoxNew True 10
boxPackStart buttonBox buttonBoxTop PackNatural 0
buttonBoxAddRmLayers <- hBoxNew True 10
boxPackStart buttonBox buttonBoxAddRmLayers PackNatural 0
buttonAddLayer <- buttonNewFromStockWithLabel gtkMediaAdd "Add layer"
let addLayerRV = buttonActivateField buttonAddLayer
boxPackStart buttonBoxAddRmLayers buttonAddLayer PackGrow 0
buttonRmLayer <- buttonNewFromStockWithLabel gtkMediaRemove "Remove layer"
let rmLayerRV = buttonActivateField buttonRmLayer
boxPackStart buttonBoxAddRmLayers buttonRmLayer PackGrow 0
buttonBoxSaveLoad <- hBoxNew True 10
boxPackStart buttonBox buttonBoxSaveLoad PackNatural 0
buttonSave <- buttonNewFromStockWithLabel gtkMediaSave "_Save configuration"
let confSaveRV = buttonActivateField buttonSave
boxPackStart buttonBoxTop buttonSave PackGrow 0
boxPackStart buttonBoxSaveLoad buttonSave PackGrow 0
buttonLoad <- buttonNewFromStockWithLabel gtkMediaOpen "_Load configuration"
let confLoadRV = buttonActivateField buttonLoad
boxPackStart buttonBoxTop buttonLoad PackGrow 0
boxPackStart buttonBoxSaveLoad buttonLoad PackGrow 0
buttonBoxBot <- hBoxNew True 10
......@@ -98,4 +93,6 @@ getButtons = do
, recordRV
, confSaveRV
, confLoadRV
, addLayerRV
, rmLayerRV
)
{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-}
module RMCA.GUI.MultiBoard where
import Control.Monad
import Data.Array
import Data.ReactiveValue
import Graphics.UI.Gtk
import Graphics.UI.Gtk.Board.BoardLink
import Graphics.UI.Gtk.Layout.BackgroundContainer
import RMCA.Auxiliary
import RMCA.GUI.Board
import RMCA.GUI.NoteSettings
import RMCA.Layer.Layer
import RMCA.Semantics
-- In GTk, a “thing with tabs” has the I think very confusing name
-- Notebook.
createNotebook :: ( ReactiveValueRead addLayer () IO
, ReactiveValueRead rmLayer () IO
, ReactiveValueRead layer Layer IO
, ReactiveValueRead tempo Tempo IO
) => addLayer -> rmLayer -> layer -> tempo
-> IO ( Notebook
, VBox
, ReactiveFieldRead IO Board
, Array Pos (ReactiveFieldWrite IO GUICell)
, ReactiveFieldWrite IO [PlayHead]
)
createNotebook addLayerRV rmLayerRV layerRV tempoRV = do
n <- notebookNew
--plusImg <- imageNewFromStock gtkMediaAdd IconSizeButton
--notebookAppendPageMenu n undefined plusImg undefined
------------------------------------------------------------------------------
-- First board
------------------------------------------------------------------------------
boardCont <- backgroundContainerNew
guiBoard <- attachGameRules =<< initGame
centerBoard <- alignmentNew 0.5 0.5 0 0
containerAdd centerBoard guiBoard
containerAdd boardCont centerBoard
notebookPrependPage n boardCont "Lol first"
notebookPageNumber <- newCBMVarRW 1
layer <- reactiveValueRead layerRV
tempo <- reactiveValueRead tempoRV
(boardRV, pieceArrRV, phRV) <- initBoardRV guiBoard
pieceBox <- clickHandling pieceArrRV guiBoard =<< vBoxNew False 10
------------------------------------------------------------------------------
-- Following boards
------------------------------------------------------------------------------
reactiveValueOnCanRead addLayerRV $ postGUIAsync $ do
reactiveValueRead notebookPageNumber
>>= reactiveValueWrite notebookPageNumber . (+1)
boardCont <- backgroundContainerNew
guiBoard <- attachGameRules =<< initGame
centerBoard <- alignmentNew 0.5 0.5 0 0
containerAdd centerBoard guiBoard
containerAdd boardCont centerBoard
notebookAppendPage n boardCont "sdlkfhd" >> widgetShowAll n
reactiveValueOnCanRead rmLayerRV $ postGUIAsync $ do
np <- reactiveValueRead notebookPageNumber
when (np > 1) $ do
notebookRemovePage n =<< notebookGetCurrentPage n
reactiveValueRead notebookPageNumber
>>= reactiveValueWrite notebookPageNumber . (subtract 1)
widgetShowAll n
return ()
------------------------------------------------------------------------------
-- For good measure
------------------------------------------------------------------------------
return (n, pieceBox, boardRV, pieceArrRV, phRV)
module RMCA.GUI.StockId where
import System.Glib
gtkMediaPlay :: DefaultGlibString
gtkMediaPlay = stringToGlib "gtk-media-play"
gtkMediaStop :: DefaultGlibString
gtkMediaStop = stringToGlib "gtk-media-stop"
gtkMediaPause :: DefaultGlibString
gtkMediaPause = stringToGlib "gtk-media-pause"
gtkMediaRecord :: DefaultGlibString
gtkMediaRecord = stringToGlib "gtk-media-record"
gtkMediaSave :: DefaultGlibString
gtkMediaSave = stringToGlib "gtk-save"
gtkMediaOpen :: DefaultGlibString
gtkMediaOpen = stringToGlib "gtk-open"
gtkMediaAdd :: DefaultGlibString
gtkMediaAdd = stringToGlib "gtk-add"
gtkMediaRemove :: DefaultGlibString
gtkMediaRemove = stringToGlib "gtk-remove"
......@@ -24,7 +24,7 @@ layerTempo = proc (t, Layer { relTempo = r }) ->
layerMetronome :: SF (Tempo, Layer) (Event BeatNo)
layerMetronome = proc (t,l@Layer { beatsPerBar = bpb }) -> do
eb <- metronome <<< layerTempo -< (t,l)
accumBy (\bn bpb -> nextBeatNo bpb bn) 1 -< eb `tag` bpb
accumBy (flip nextBeatNo) 1 -< eb `tag` bpb
layerRV :: CBMVar Layer -> ReactiveFieldReadWrite IO Layer
layerRV mvar = ReactiveFieldReadWrite setter getter notifier
......
......@@ -15,6 +15,7 @@ import RMCA.GUI.Board
import RMCA.GUI.Buttons
import RMCA.GUI.LayerSettings
import RMCA.GUI.MainSettings
import RMCA.GUI.MultiBoard
import RMCA.GUI.NoteSettings
import RMCA.Layer.Board
import RMCA.Translator.Jack
......@@ -48,21 +49,16 @@ main = do
laySep <- hSeparatorNew
boxPackStart settingsBox laySep PackNatural 0
(buttonBox, playRV, stopRV, pauseRV, recordRV, confSaveRV, confLoadRV) <- getButtons
( buttonBox
, playRV, stopRV, pauseRV, recordRV
, confSaveRV, confLoadRV
, addLayerRV, rmLayerRV ) <- getButtons
boxPackEnd settingsBox buttonBox PackNatural 0
-- Board
boardCont <- backgroundContainerNew
guiBoard <- attachGameRules =<< initGame
centerBoard <- alignmentNew 0.5 0.5 0 0
containerAdd centerBoard guiBoard
containerAdd boardCont centerBoard
( boardCont, pieceBox
, boardRV, pieceArrRV, phRV) <- createNotebook addLayerRV rmLayerRV layerRV tempoRV
boxPackStart mainBox boardCont PackNatural 0
------------------------------------------------------------------------------
-- Board setup
layer <- reactiveValueRead layerRV
tempo <- reactiveValueRead tempoRV
(boardRV, pieceArrRV, phRV) <- initBoardRV guiBoard
handleSaveLoad tempoRV boardRV layerRV instrRV pieceArrRV confSaveRV confLoadRV
......@@ -70,6 +66,8 @@ main = do
reactiveValueOnCanRead playRV $ reactiveValueWrite boardRunRV BoardStart
reactiveValueOnCanRead stopRV $ reactiveValueWrite boardRunRV BoardStop
board <- reactiveValueRead boardRV
layer <- reactiveValueRead layerRV
tempo <- reactiveValueRead tempoRV
(inBoard, outBoard) <- yampaReactiveDual (board, layer, tempo, BoardStop) boardSF
let tempoRV' = liftR2 (\bool t -> t * fromEnum (not bool)) pauseRV tempoRV
inRV = liftR4 (,,,)
......@@ -87,7 +85,6 @@ main = do
-- Jack setup
forkIO $ jackSetup tempoRV chanRV boardQueue
widgetShowAll window
pieceBox <- clickHandling pieceArrRV guiBoard =<< vBoxNew False 10
------------------------------------------------------------
boxPackStart settingsBox pieceBox PackNatural 10
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment