Commit 1364e9e7 authored by Guerric Chupin's avatar Guerric Chupin

Removed most warnings and solved non-rotating tile problem.

parent 2a0dedd5
......@@ -25,4 +25,5 @@ html/
/GUI/
/img/Shapes.hs
/dist
*.save*
\ No newline at end of file
*.save*
*.txt
\ No newline at end of file
......@@ -49,4 +49,4 @@ executable RMCA
hs-source-dirs: src
build-tools: hsc2hs
default-language: Haskell2010
ghc-options: -O2 -threaded
ghc-options: -O2 -threaded -W
......@@ -10,7 +10,7 @@ import FRP.Yampa
stepBack :: SF a (Maybe a)
stepBack = sscan f (Nothing, Nothing) >>^ snd
where f :: (Maybe a, Maybe a) -> a -> (Maybe a, Maybe a)
f (Nothing,Nothing) x' = (Just x', Nothing)
f (Nothing,_) x' = (Just x', Nothing)
f (Just x, _) x' = (Just x', Just x)
-- Just like stepBack but the output value is always defined and is
......@@ -25,10 +25,6 @@ stepBack' = proc x -> do
onChange :: (Eq a) => SF a (Event a)
onChange = proc x -> do
x' <- stepBack -< x
let makeEvent x x'
| isNothing x' = NoEvent
| isJust x' = let x'' = fromJust x' in
if x'' == x then NoEvent else Event x
returnA -< makeEvent x x'
-- Similar to onChange but contains its initial value in the first
......@@ -36,13 +32,13 @@ onChange = proc x -> do
onChange' :: (Eq a) => SF a (Event a)
onChange' = proc x -> do
x' <- stepBack -< x
-- If it's the first value, throw an Event, else behave like onChange.
let makeEvent x x'
| isNothing x' = Event x
| isJust x' = let x'' = fromJust x' in
if x'' == x then NoEvent else Event x
returnA -< makeEvent x x'
makeEvent x x'
| isNothing x' = Event x
| otherwise = let x'' = fromJust x' in
if x'' == x then NoEvent else Event x
discard :: a -> ()
discard _ = ()
......
......@@ -8,6 +8,15 @@ import FRP.Yampa
import Control.Monad
import RMCA.Auxiliary.Curry
leftSyncWith :: (ReactiveValueRead a b m, ReactiveValueWrite c d m) =>
(b -> d) -> a -> c -> m ()
leftSyncWith f a c = reactiveValueOnCanRead a
(reactiveValueRead a >>= reactiveValueWrite c . f)
(=:$:>) :: (ReactiveValueRead a b m, ReactiveValueWrite c d m) =>
(b -> d) -> a -> c -> m ()
(=:$:>) = leftSyncWith
newCBMVarRW :: forall a. a -> IO (ReactiveFieldReadWrite IO a)
newCBMVarRW val = do
mvar <- newCBMVar val
......
......@@ -3,9 +3,7 @@
module RMCA.GUI.Board where
import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.IO.Class
import Data.Array
import Data.Array.MArray
import qualified Data.Bifunctor as BF
......@@ -14,9 +12,6 @@ import Data.CBMVar
import Data.Maybe
import Data.Ratio
import Data.ReactiveValue
import Data.String
import Data.Tuple
import Debug.Trace
import Game.Board.BasicTurnGame
import Graphics.UI.Gtk hiding (Action)
import Graphics.UI.Gtk.Board.BoardLink
......@@ -145,7 +140,7 @@ instance PlayableGame GUIBoard Int Tile Player GUICell where
canMoveTo _ _ _ fPos = fPos `elem` validArea
|| outGUIBoard fPos
move guiBoard@(GUIBoard game) p iPos@(_,yi) fPos@(xf,yf)
move (GUIBoard game) _ iPos@(_,yi) fPos@(xf,yf)
| outGUIBoard iPos && outGUIBoard fPos = []
| outGUIBoard fPos = [ RemovePiece iPos
, AddPiece iPos Player nCell ]
......@@ -169,7 +164,7 @@ instance PlayableGame GUIBoard Int Tile Player GUICell where
}
| otherwise = inertCell
applyChange (GUIBoard game) (AddPiece pos@(x,y) Player piece) =
applyChange (GUIBoard game) (AddPiece (x,y) Player piece) =
GUIBoard $ game { boardPieces' = bp' }
where bp' = (x,y,Player,piece):boardPieces' game
......@@ -208,7 +203,7 @@ initBoardRV :: BIO.Board Int Tile (Player,GUICell)
-> IO ( ReactiveFieldRead IO Board
, Array Pos (ReactiveFieldWrite IO GUICell)
, ReactiveFieldReadWrite IO [PlayHead])
initBoardRV board@BIO.Board { boardPieces = gBoard@(GameBoard gArray) } = do
initBoardRV board@BIO.Board { boardPieces = (GameBoard gArray) } = do
-- RV creation
phMVar <- newCBMVar []
notBMVar <- mkClockRV 100
......@@ -231,8 +226,7 @@ initBoardRV board@BIO.Board { boardPieces = gBoard@(GameBoard gArray) } = do
setterP :: [PlayHead] -> IO ()
setterP lph = do
oph <- readCBMVar phMVar
let phPosS = map phPos lph
offPh :: PlayHead -> IO ()
let offPh :: PlayHead -> IO ()
offPh ph = do
let pos = toGUICoords $ phPos ph
piece <- boardGetPiece pos board
......
-- Contains button name definition
module RMCA.GUI.Buttons where
import Graphics.UI.Gtk
import System.Glib
gtkMediaPlay :: DefaultGlibString
......
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ScopedTypeVariables, TupleSections #-}
module RMCA.GUI.Settings where
......@@ -11,13 +11,26 @@ import Data.Maybe
import Data.ReactiveValue
import Data.String
import Data.Tuple
import Graphics.UI.Gtk
import Graphics.UI.Gtk hiding (Action)
import Graphics.UI.Gtk.Board.TiledBoard hiding (Board)
import Graphics.UI.Gtk.Reactive
import RMCA.Auxiliary.RV
import RMCA.GUI.Board
import RMCA.Semantics
setNAttr :: NoteAttr -> Action -> Action
setNAttr _ Inert = Inert
setNAttr _ Absorb = Absorb
setNAttr na (Stop _) = Stop na
setNAttr na (ChDir b _ dir) = ChDir b na dir
setNAttr na (Split _) = Split na
getNAttr :: Action -> Maybe NoteAttr
getNAttr Inert = Nothing
getNAttr Absorb = Nothing
getNAttr (Stop na) = Just na
getNAttr (ChDir _ na _) = Just na
getNAttr (Split na) = Just na
comboBoxIndexRV :: (ComboBoxClass box) =>
box -> ReactiveFieldReadWrite IO Int
comboBoxIndexRV box = ReactiveFieldReadWrite setter getter notifier
......@@ -57,6 +70,46 @@ clickHandling pieceArrRV board pieceBox = do
state <- newEmptyMVar
-- Side RV
setRV <- newCBMVarRW ((0,0),inertCell)
reactiveValueOnCanRead slideComboRV $ do
nSlide <- reactiveValueRead slideComboRV
(i,oCell) <- reactiveValueRead setRV
let nCa :: Maybe NoteAttr
nCa = (\na -> na { naOrn = (naOrn na) { ornSlide = nSlide } }) <$>
(getNAttr $ cellAction oCell)
nCell :: GUICell
nCell = if (isJust nCa)
then oCell { cellAction =
setNAttr (fromJust nCa) (cellAction oCell)
}
else oCell
reactiveValueWrite setRV (i,nCell)
reactiveValueOnCanRead artComboRV $ do
nArt <- reactiveValueRead artComboRV
(i,oCell) <- reactiveValueRead setRV
let nCa :: Maybe NoteAttr
nCa = getNAttr $ cellAction oCell
nCell :: GUICell
nCell = if (isJust nCa)
then oCell { cellAction =
setNAttr (fromJust nCa) (cellAction oCell) }
else oCell
reactiveValueWrite setRV (i,nCell)
let hideNa :: IO ()
hideNa = widgetHide slideCombo >> widgetHide artCombo
showNa :: IO ()
showNa = widgetShow slideCombo >> widgetShow artCombo
updateNaBox :: GUICell -> IO ()
updateNaBox GUICell { cellAction = act } = case act of
Inert -> hideNa
Absorb -> hideNa
_ -> showNa
boardOnPress board
(\iPos -> liftIO $ do
postGUIAsync $ void $ tryPutMVar state iPos
......@@ -68,29 +121,17 @@ clickHandling pieceArrRV board pieceBox = do
mp <- boardGetPiece fPos board
mstate <- tryTakeMVar state
when (fPos `elem` validArea && isJust mp) $ do
when (maybe False (== fPos) mstate) $
boardSetPiece fPos (BF.second rotateGUICell $
fromJust mp) board
let hideNa :: IO ()
hideNa = widgetHide slideCombo >> widgetHide artCombo
showNa :: IO ()
showNa = widgetShow slideCombo >> widgetShow artCombo
updateNaBox :: GUICell -> IO ()
updateNaBox GUICell { cellAction = act } = case act of
Inert -> hideNa
Absorb -> hideNa
_ -> print "Show!" >> showNa
pieceRV = pieceArrRV ! fPos
piece = snd $ fromJust mp
updateNaBox piece
setRV <- newCBMVarRW $ piece
reactiveValueOnCanRead slideComboRV $ do
nSlide <- reactiveValueWrite slideComboRV
oCell <- reactiveValueRead setRV
reactiveValueWrite setRV (setSlide oCell nSlide)
setRV =:> pieceRV
reactiveValueOnCanRead setRV $ updateNaBox $ piece
let piece = snd $ fromJust mp
when (maybe False (== fPos) mstate) $ do
boardSetPiece fPos (BF.second rotateGUICell (Player,piece)) board
nmp <- boardGetPiece fPos board
when (isJust nmp) $ reactiveValueWrite setRV $ (fPos,snd $ fromJust nmp)
return True
)
reactiveValueOnCanRead setRV $ do
(i,c) <- reactiveValueRead setRV
reactiveValueWrite (pieceArrRV ! i) c
updateNaBox c
widgetShow pieceBox >> widgetShow naBox
return pieceBox
......@@ -3,27 +3,17 @@
module RMCA.Layer.Board ( boardSF
) where
import Control.Concurrent
import Control.Concurrent.MVar
import Control.Monad
import Data.ReactiveValue
import Data.Tuple
import FRP.Yampa
import Hails.Yampa
import RMCA.Auxiliary.Curry
import RMCA.Global.Clock
import RMCA.Layer.Layer
import RMCA.Semantics
import Debug.Trace
-- The state of the board is described by the list of the playheads
-- and the different actions onto the board.
boardAction :: SF ((Board, Layer, [PlayHead]), Event BeatNo)
(Event ([PlayHead], [Note]))
boardAction = proc ((board, Layer { relPitch = rp
, strength = s
, beatsPerBar = bpb
},ph), ebno) ->
arr $ fmap (uncurry5 advanceHeads)
-< ebno `tag` (board, fromEvent ebno, rp, s, ph)
......
......@@ -8,8 +8,6 @@ import FRP.Yampa
import RMCA.Global.Clock
import RMCA.Semantics
import Debug.Trace
-- Data representing the state of a layer. It is updated continuously.
data Layer = Layer { relTempo :: Double
, relPitch :: RelPitch
......
......@@ -3,26 +3,14 @@
module Main where
import Control.Concurrent
import Control.Monad
import Control.Monad.IO.Class
import Data.Array
import Data.Array.IO
import Data.Array.MArray
import Data.Maybe
import Data.ReactiveValue
import Data.String
import Data.Tuple
import FRP.Yampa
import Game.Board.BasicTurnGame
import Graphics.UI.Gtk
import Graphics.UI.Gtk.Board.BoardLink
import Graphics.UI.Gtk.Board.TiledBoard
import Graphics.UI.Gtk.Layout.BackgroundContainer
import Graphics.UI.Gtk.Reactive
import Hails.Yampa
import RMCA.Auxiliary.Concurrent
import RMCA.Auxiliary.RV
import RMCA.Global.Clock
import RMCA.GUI.Board
import RMCA.GUI.Buttons
import RMCA.GUI.Settings
......@@ -30,8 +18,6 @@ import RMCA.Layer.Board
import RMCA.Layer.Layer
import RMCA.Semantics
import RMCA.Translator.Jack
import RMCA.Translator.Message
import RMCA.Translator.Translator
floatConv :: (ReactiveValueReadWrite a b m,
Real c, Real b, Fractional c, Fractional b) =>
......@@ -189,7 +175,6 @@ main = do
(inBoard, outBoard) <- yampaReactiveDual (board, layer, ph, tempo) boardSF
let inRV = liftR4 id
boardRV layerRV phRV tempoRV
clock <- mkClockRV 100
--let inRV = onTick clock inRV
inRV =:> inBoard
reactiveValueOnCanRead outBoard $ do
......
......@@ -33,9 +33,8 @@
module RMCA.Semantics where
import Data.Array
import Data.List (intercalate, intersperse, nub)
import Data.List (intercalate, nub)
import Data.Maybe (catMaybes)
import Data.Ratio
import RMCA.Auxiliary.Auxiliary
......
......@@ -4,13 +4,9 @@
module RMCA.Translator.Filter where
import Data.Bifunctor as BF
import Data.Function (on)
import Data.List (group, groupBy, sortBy)
import Data.List (sortBy)
import Data.Ord
import FRP.Yampa
import RMCA.Semantics
import RMCA.Translator.Message
import Sound.JACK (NFrames (NFrames))
-- Takes a list of time stamped "things", a sample rate and a buffer
-- size. The function argument is a function that needs to tell which
......@@ -44,7 +40,7 @@ nubDuplicate f = map (BF.second f) . scatterEvents
-- the first frame of the next list is at least one frame after the
-- last frame of that list.
scatterEvents :: [(Frames, a)] -> [(Frames, a)]
scatterEvents (x@(n,a):(m,b):xs) = x:scatterEvents ((m',b):xs)
scatterEvents (x@(n,_):(m,b):xs) = x:scatterEvents ((m',b):xs)
where m' = m + max 0 (1 + n - m)
scatterEvents [x] = [x]
scatterEvents _ = []
......@@ -10,7 +10,6 @@ import qualified Control.Monad.Exception.Synchronous as Sync
import qualified Control.Monad.Trans.Class as Trans
import qualified Data.Bifunctor as BF
import Data.CBMVar
import qualified Data.EventList.Absolute.TimeBody as EventListAbs
import Data.ReactiveValue
import qualified Foreign.C.Error as E
import Hails.Yampa
......@@ -21,11 +20,8 @@ import RMCA.Translator.Message
import RMCA.Translator.RV
import RMCA.Translator.Translator
import qualified Sound.JACK as Jack
import qualified Sound.JACK.Exception as JExc
import qualified Sound.JACK.MIDI as JMIDI
import Debug.Trace
rmcaName :: String
rmcaName = "RMCA"
......@@ -95,7 +91,7 @@ jackCallBack client input output toProcessRV tempoRV chanRV outBoard
-- This gets the sample rate of the client and the last frame number
-- it processed. We then use it to calculate the current absolute time
sr <- Trans.lift $ Jack.getSampleRate client
(Jack.NFrames lframeInt) <- Trans.lift $ Jack.lastFrameTime client
--(Jack.NFrames lframeInt) <- Trans.lift $ Jack.lastFrameTime client
--Trans.lift (reactiveValueRead inMIDIRV >>= (print . map (fst)))
-- We write the content of the input buffer to the input of a
-- translation signal function.
......
module RMCA.Translator.Message where
import RMCA.Semantics
import qualified Sound.JACK as Jack
import qualified Sound.MIDI.Message as Message
import qualified Sound.MIDI.Message.Channel as Channel
import qualified Sound.MIDI.Message.Channel.Voice as Voice
......@@ -61,6 +60,7 @@ isControl _ = False
switchOnOff :: Message -> Message
switchOnOff (NoteOn c p v) = NoteOff c p v
switchOnOff (NoteOff c p v) = NoteOn c p v
switchOnOff m = error $ "The message " ++ show m ++ " is not a note message"
fromRawMessage :: RawMessage -> Maybe Message
fromRawMessage (Message.Channel (Channel.Cons c
......
......@@ -5,7 +5,6 @@ module RMCA.Translator.Note where
import Data.Ratio
import FRP.Yampa
import RMCA.Global.Clock
import RMCA.Layer.Layer
import RMCA.Semantics
import RMCA.Translator.Message
......@@ -15,6 +14,8 @@ messageToNote (NoteOn _ p s) = Note { notePch = p
, noteDur = 1 % 4
, noteOrn = noOrn
}
messageToNote m = error $ "In messageToNote: the message "
++ show m ++ " is not a note message"
-- noteToMessage gives a pair of two time-stamped messages. The one on
-- the left is a note message, the other a note off.
......@@ -24,10 +25,7 @@ noteToMessages :: LTempo
-> (Frames,Note) -- Note to convert
-> [(Frames,Message)]
noteToMessages layTempo sr chan =
proc (t,n@Note { notePch = p
, noteStr = s
, noteDur = d
}) -> do
proc (t,n@Note { noteDur = d }) -> do
nm <- noteOnToMessage chan -< n
let dt = fromRational (d * toRational (tempoToQNoteIvl layTempo))
dn = floor $ dt * fromIntegral sr
......
......@@ -2,28 +2,19 @@
module RMCA.Translator.RV where
import Control.Monad
import Control.Monad.Exception.Synchronous (ExceptionalT, resolveT)
import qualified Control.Monad.Trans.Class as Trans
import qualified Data.Bifunctor as BF
import Data.CBMVar
import qualified Data.EventList.Absolute.TimeBody as EventListAbs
import qualified Data.List as L
import Data.Ord (comparing)
import Data.ReactiveValue
import qualified Foreign.C.Error as E
import RMCA.Translator.Message
import qualified Sound.JACK as Jack
import Sound.JACK.Exception
( All
, ThrowsErrno
, toStringWithHead
)
import Sound.JACK.Exception (All, toStringWithHead)
import qualified Sound.JACK.MIDI as JMIDI
import qualified System.IO as IO
import Debug.Trace
handleError :: (Monoid a) => ExceptionalT All IO a -> IO a
handleError = resolveT $ \e -> do
IO.hPutStrLn IO.stderr $ toStringWithHead e
......
......@@ -11,7 +11,6 @@ import qualified Data.Bifunctor as BF
import Data.Function (on)
import Data.List (groupBy)
import Data.Maybe
import Data.Ratio
import FRP.Yampa
import RMCA.Semantics
import RMCA.Translator.Controller
......
......@@ -7,7 +7,6 @@ module RMCA.Translator.Translator ( readMessages
import qualified Data.Bifunctor as BF
import FRP.Yampa
import RMCA.Auxiliary.Curry
import RMCA.Layer.Layer
import RMCA.Semantics
import RMCA.Translator.Controller
import RMCA.Translator.Message
......
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