From f62dc879eadd8f0cf505ebfba1abeffc9f385c77 Mon Sep 17 00:00:00 2001 From: Guerric Chupin Date: Mon, 27 Jun 2016 05:13:27 +0100 Subject: [PATCH 01/16] Playheads and notes are correct. --- CLOC.md | 6 +++--- RMCA/GUI/Board.hs | 8 +++----- RMCA/Layer/Board.hs | 3 ++- RMCA/Main.hs | 12 ++++++------ 4 files changed, 14 insertions(+), 15 deletions(-) diff --git a/CLOC.md b/CLOC.md index e35a774..76709f8 100644 --- a/CLOC.md +++ b/CLOC.md @@ -1,9 +1,9 @@ -cloc|https://github.com/AlDanial/cloc v 1.66 T=0.07 s (375.7 files/s, 27369.1 lines/s) +cloc|https://github.com/AlDanial/cloc v 1.66 T=0.06 s (404.7 files/s, 32964.5 lines/s) --- | --- Language|files|blank|comment|code :-------|-------:|-------:|-------:|-------: -Haskell|25|299|393|1129 +Haskell|26|335|430|1353 --------|--------|--------|--------|-------- -SUM:|25|299|393|1129 +SUM:|26|335|430|1353 diff --git a/RMCA/GUI/Board.hs b/RMCA/GUI/Board.hs index dad3c76..c9cf029 100644 --- a/RMCA/GUI/Board.hs +++ b/RMCA/GUI/Board.hs @@ -184,11 +184,11 @@ initBoardRV board@BIO.Board { boardPieces = gBoard@(GameBoard array) } = do setterP :: [PlayHead] -> IO () setterP lph = do - let phPosS = map phPos lph readCBMVar phMVar >>= writeCBMVar oldphMVar - oph <- readCBMVar oldphMVar writeCBMVar phMVar lph - let offPh :: PlayHead -> IO () + oph <- readCBMVar oldphMVar + let phPosS = map phPos lph + offPh :: PlayHead -> IO () offPh ph = do let pos = toGUICoords $ phPos ph piece <- boardGetPiece pos board @@ -203,9 +203,7 @@ initBoardRV board@BIO.Board { boardPieces = gBoard@(GameBoard array) } = do let (_,c) = fromJust piece boardSetPiece pos (Player, c { asPh = True }) board mapM_ offPh oph - print oph mapM_ onPh lph - print lph notifierP :: IO () -> IO () notifierP = installCallbackCBMVar phMVar diff --git a/RMCA/Layer/Board.hs b/RMCA/Layer/Board.hs index 5a3e825..7cc8c26 100644 --- a/RMCA/Layer/Board.hs +++ b/RMCA/Layer/Board.hs @@ -19,7 +19,8 @@ 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 :: SF ((Board, Layer, [PlayHead]), Event BeatNo) + (Event ([PlayHead], [Note])) boardAction = proc ((board, Layer { relPitch = rp , strength = s , beatsPerBar = bpb diff --git a/RMCA/Main.hs b/RMCA/Main.hs index 208f95b..1310ad4 100644 --- a/RMCA/Main.hs +++ b/RMCA/Main.hs @@ -159,6 +159,7 @@ main = do buttonPause <- buttonNewFromStock gtkMediaPause boxPackStart buttonBox buttonPause PackRepel 0 buttonStop <- buttonNewFromStock gtkMediaStop + let stopRV = buttonActivateField buttonStop boxPackStart buttonBox buttonStop PackRepel 0 buttonRecord <- buttonNewFromStock gtkMediaRecord boxPackStart buttonBox buttonRecord PackRepel 0 @@ -180,11 +181,10 @@ main = do (boardRV, phRV) <- initBoardRV guiBoard reactiveValueOnCanRead playRV (reactiveValueRead boardRV >>= reactiveValueWrite phRV . startHeads) + reactiveValueOnCanRead stopRV $ reactiveValueWrite phRV [] board <- reactiveValueRead boardRV ph <- reactiveValueRead phRV (inBoard, outBoard) <- yampaReactiveDual (board, layer, ph, tempo) boardSF - (splitE >>> fst) <^> outBoard >:> phRV - --reactiveValueOnCanRead phRV $ boardRefresh guiBoard let inRV = liftR4 id boardRV layerRV phRV tempoRV clock <- mkClockRV 100 @@ -194,10 +194,10 @@ main = do bq <- reactiveValueRead boardQueue ob <- reactiveValueRead $ liftR (event [] id <<< snd <<< splitE) outBoard reactiveValueWrite boardQueue (bq ++ ob) - -- /!\ To be removed. - --reactiveValueOnCanRead inRV (reactiveValueRead inRV >>= print . \(_,_,ph,_) -> ph) - --reactiveValueOnCanRead outBoard (reactiveValueRead outBoard >>= print) - reactiveValueOnCanRead phRV (reactiveValueRead phRV >>= print) + -- This needs to be set last otherwise phRV is written to, so + -- inBoard is written to and the notes don't get played. There + -- supposedly is no guaranty of order but apparently there is… + (fst <$>) <^> outBoard >:> phRV putStrLn "Board started." -- Jack setup forkIO $ jackSetup tempoRV (constR 0) boardQueue -- 2.44.1 From 040987a3e0e1aa8a3db5eceed1f145e8a822f57b Mon Sep 17 00:00:00 2001 From: Guerric Chupin Date: Mon, 27 Jun 2016 14:00:08 +0100 Subject: [PATCH 02/16] Tile adding supported. --- RMCA/GUI/Board.hs | 54 +++++++++++++++++++++++++++++++++++------------ RMCA/Main.hs | 8 +++---- 2 files changed, 44 insertions(+), 18 deletions(-) diff --git a/RMCA/GUI/Board.hs b/RMCA/GUI/Board.hs index c9cf029..30704e2 100644 --- a/RMCA/GUI/Board.hs +++ b/RMCA/GUI/Board.hs @@ -60,23 +60,43 @@ xMin, yMin :: Int boardToTile :: [(Int,Int,Tile)] boardToTile = [(x,y,Tile) | (x,y) <- range ( (xMin-1,yMin) - , (xMax+1,yMax+1))] - - + , (xMax+3,yMax+1))] + +defNa :: NoteAttr +defNa = NoteAttr { naArt = NoAccent + , naDur = 1 % 4 + , naOrn = noOrn + } + +ctrlPieces :: [(Int,Int,Player,GUICell)] +ctrlPieces = [(xMax+2,y,Player,GUICell { cellAction = action + , repeatCount = 1 + , asPh = False + }) + | let actions = [ Absorb, Stop defNa + , ChDir False defNa N, ChDir True defNa N + , Split defNa] + -- /!\ It would be nice to find a general formula + -- for placing the control pieces. + , (y,action) <- zip [ yMin+4,yMin+8..] actions] + +ctrlCoord = map (\(x,y,_,_) -> (x,y)) ctrlPieces boardToPiece :: [PlayHead] -> Board -> [(Int,Int,Player,GUICell)] -boardToPiece ph = map placePiece . filter (onBoard . fst) . assocs +boardToPiece ph = (++ ctrlPieces) . map placePiece . + filter (onBoard . fst) . assocs where placePiece :: (Pos,Cell) -> (Int,Int,Player,GUICell) - placePiece ((x,y),(a,n)) = let y' = 2*(-y) + x `mod` 2 - c = GUICell { cellAction = a + placePiece ((x,y),(a,n)) = let c = GUICell { cellAction = a , repeatCount = n , asPh = (x,y) `elem` phPosS } - in (x,y',Player,c) + (x',y') = toGUICoords (x,y) + in (x',y',Player,c) phPosS = map phPos ph -validArea :: Board -> [(Int,Int)] -validArea = map (\(x,y,_,_) -> (x,y)) . boardToPiece [] +validArea :: [(Int,Int)] +validArea = filter (onBoard . fromGUICoords) $ + map (\(x,y,_,_) -> (x,y)) $ boardToPiece [] $ makeBoard [] na = NoteAttr { naArt = Accent13, @@ -102,20 +122,26 @@ instance PlayableGame GUIBoard Int Tile Player GUICell where canMove (GUIBoard game) _ (x,y) | Just (_,p) <- getPieceAt game (x,y) , GUICell { cellAction = Inert } <- p = False + | Nothing <- getPieceAt game (x,y) = False | otherwise = True canMoveTo _ _ _ (x,y) = (x,y) `elem` validArea - where validArea = map (\(x',y',_,_) -> (x',y')) $ boardToPiece [] $ - makeBoard [] - move (GUIBoard game) _ iPos@(_,yi) (xf,yf) = [ MovePiece iPos fPos' - , AddPiece iPos Player nCell] + move guiBoard@(GUIBoard game) p iPos@(_,yi) (xf,yf) + | not (canMove guiBoard p iPos) = [] + | not (canMoveTo guiBoard p iPos fPos') = [] + | iPos `elem` ctrlCoord = [ RemovePiece fPos' + , AddPiece fPos' Player (nCell { cellAction = ctrlAction }) + ] + | otherwise = [ MovePiece iPos fPos' + , AddPiece iPos Player nCell] where fPos' | (xf `mod` 2 == 0 && yf `mod` 2 == 0) || (xf `mod` 2 /= 0 && yf `mod` 2 /= 0) = (xf,yf) - | otherwise = (xf,yf+signum' (yf-yi)) + | otherwise = (xf,yf)-- (xf,yf+signum' (yf-yi)) signum' x | x == 0 = 1 | otherwise = signum x + ctrlAction = cellAction $ snd $ fromJust $ getPieceAt game iPos nCell | Just (_,GUICell { asPh = ph, repeatCount = n }) <- getPieceAt game iPos = inertCell { repeatCount = n diff --git a/RMCA/Main.hs b/RMCA/Main.hs index 1310ad4..efcb981 100644 --- a/RMCA/Main.hs +++ b/RMCA/Main.hs @@ -77,7 +77,7 @@ main = do initGUI window <- windowNew -- Main box - mainBox <- hBoxNew True 0 + mainBox <- hBoxNew False 10 set window [ windowTitle := "Reactogon" --, windowDefaultWidth := 250 --, windowDefaultHeight := 500 @@ -168,9 +168,9 @@ main = do boardCont <- backgroundContainerNew game <- initGame guiBoard <- attachGameRules game - --centerBoard <- alignmentNew 0.5 0.5 0 0 - containerAdd boardCont guiBoard - --containerAdd boardCont centerBoard + centerBoard <- alignmentNew 0.5 0.5 0 0 + containerAdd centerBoard guiBoard + containerAdd boardCont centerBoard boxPackStart mainBox boardCont PackNatural 0 --boxPackStart mainBox boardCont PackNatural 0 ------------------------------------------------------------------------------ -- 2.44.1 From b096298985c451f6e58b454a1809fd301c77eaf9 Mon Sep 17 00:00:00 2001 From: Guerric Chupin Date: Mon, 27 Jun 2016 17:54:28 +0100 Subject: [PATCH 03/16] Corrected piece size. --- img/absorb.svg | 56 ++++++++++++++++++++++++++++++++++++++ img/ricN.svg | 66 ++++++++++++++++++++++++++++++++++++++------- img/ricNE.svg | 35 ++++++++++++------------ img/ricNW.svg | 36 ++++++++++++------------- img/ricS.svg | 34 +++++++++++------------ img/ricSE.svg | 36 ++++++++++++------------- img/ricSW.svg | 36 ++++++++++++------------- img/split.svg | 67 ++++++++++++++++++++++++++++++++++++++------- img/startN.svg | 72 ++++++++++++++++++++++++++++++++++++++++++------- img/startNE.svg | 30 ++++++++++----------- img/startNW.svg | 42 ++++++++++++++--------------- img/startS.svg | 34 +++++++++++------------ img/startSE.svg | 42 ++++++++++++++--------------- img/startSW.svg | 42 ++++++++++++++--------------- img/stop.svg | 68 +++++++++++++++++++++++++++++++++++++++------- 15 files changed, 476 insertions(+), 220 deletions(-) create mode 100644 img/absorb.svg diff --git a/img/absorb.svg b/img/absorb.svg new file mode 100644 index 0000000..1729066 --- /dev/null +++ b/img/absorb.svg @@ -0,0 +1,56 @@ + + + +image/svg+xml \ No newline at end of file diff --git a/img/ricN.svg b/img/ricN.svg index e054fa4..b0f576d 100644 --- a/img/ricN.svg +++ b/img/ricN.svg @@ -1,9 +1,57 @@ - - - - - - - + + + +image/svg+xml \ No newline at end of file diff --git a/img/ricNE.svg b/img/ricNE.svg index 6e6e777..da8e0cd 100644 --- a/img/ricNE.svg +++ b/img/ricNE.svg @@ -17,10 +17,10 @@ xml:space="preserve" inkscape:version="0.91 r13725" sodipodi:docname="ricNE.svg">image/svg+xml \ No newline at end of file + cx="136.75255" + cy="-36.86235" + r="80" + id="circle6" + style="fill:none;stroke:#ffffff;stroke-width:4;stroke-miterlimit:10" + transform="matrix(0.5,0.8660254,-0.8660254,0.5,0,0)" /> \ No newline at end of file diff --git a/img/ricNW.svg b/img/ricNW.svg index 94385f8..6638d71 100644 --- a/img/ricNW.svg +++ b/img/ricNW.svg @@ -17,10 +17,10 @@ xml:space="preserve" inkscape:version="0.91 r13725" sodipodi:docname="ricNW.svg">image/svg+xml \ No newline at end of file + cx="-36.452545" + cy="136.86235" + r="80" + id="circle6" + style="fill:none;stroke:#ffffff;stroke-width:4;stroke-miterlimit:10" + transform="matrix(0.5,-0.8660254,0.8660254,0.5,0,0)" /> \ No newline at end of file diff --git a/img/ricS.svg b/img/ricS.svg index 3d4c881..ff763b3 100644 --- a/img/ricS.svg +++ b/img/ricS.svg @@ -17,10 +17,10 @@ xml:space="preserve" inkscape:version="0.91 r13725" sodipodi:docname="ricS.svg">image/svg+xml \ No newline at end of file + cy="-100.00001" + r="80" + id="circle6" + style="fill:none;stroke:#ffffff;stroke-width:4;stroke-miterlimit:10" + transform="scale(-1,-1)" /> \ No newline at end of file diff --git a/img/ricSE.svg b/img/ricSE.svg index 52b3578..0674dd2 100644 --- a/img/ricSE.svg +++ b/img/ricSE.svg @@ -17,10 +17,10 @@ xml:space="preserve" inkscape:version="0.91 r13725" sodipodi:docname="ricSE.svg">image/svg+xml \ No newline at end of file + cx="36.452545" + cy="-136.86235" + r="80" + id="circle6" + style="fill:none;stroke:#ffffff;stroke-width:4;stroke-miterlimit:10" + transform="matrix(-0.5,0.8660254,-0.8660254,-0.5,0,0)" /> \ No newline at end of file diff --git a/img/ricSW.svg b/img/ricSW.svg index 946d315..c147c71 100644 --- a/img/ricSW.svg +++ b/img/ricSW.svg @@ -17,10 +17,10 @@ xml:space="preserve" inkscape:version="0.91 r13725" sodipodi:docname="ricSW.svg">image/svg+xml \ No newline at end of file + cx="-136.75255" + cy="36.862347" + r="80" + id="circle6" + style="fill:none;stroke:#ffffff;stroke-width:4;stroke-miterlimit:10" + transform="matrix(-0.5,-0.8660254,0.8660254,-0.5,0,0)" /> \ No newline at end of file diff --git a/img/split.svg b/img/split.svg index 82604d6..60c1302 100644 --- a/img/split.svg +++ b/img/split.svg @@ -1,9 +1,58 @@ - - - - - - - + + + +image/svg+xml \ No newline at end of file diff --git a/img/startN.svg b/img/startN.svg index 2c14278..bde05cb 100644 --- a/img/startN.svg +++ b/img/startN.svg @@ -1,10 +1,62 @@ - - - - - - - - + + + +image/svg+xml \ No newline at end of file diff --git a/img/startNE.svg b/img/startNE.svg index 113f4f8..8b1dcba 100644 --- a/img/startNE.svg +++ b/img/startNE.svg @@ -19,7 +19,7 @@ sodipodi:docname="startNE.svg">image/svg+xml \ No newline at end of file + style="fill:#ffffff" + transform="matrix(0.5,0.8660254,-0.8660254,0.5,0,0)" /> \ No newline at end of file diff --git a/img/startNW.svg b/img/startNW.svg index fc6d4a8..becc873 100644 --- a/img/startNW.svg +++ b/img/startNW.svg @@ -29,37 +29,37 @@ guidetolerance="10" inkscape:pageopacity="0" inkscape:pageshadow="2" - inkscape:window-width="720" - inkscape:window-height="480" + inkscape:window-width="1366" + inkscape:window-height="716" id="namedview10" showgrid="false" - inkscape:zoom="1.18" - inkscape:cx="100" + inkscape:zoom="2.74" + inkscape:cx="38.50365" inkscape:cy="100" inkscape:window-x="0" inkscape:window-y="26" - inkscape:window-maximized="0" + inkscape:window-maximized="1" inkscape:current-layer="Layer_1" /> \ No newline at end of file + style="fill:#ffffff" + transform="matrix(0.5,-0.8660254,0.8660254,0.5,0,0)" /> \ No newline at end of file diff --git a/img/startS.svg b/img/startS.svg index ae25005..ef2fb97 100644 --- a/img/startS.svg +++ b/img/startS.svg @@ -29,37 +29,37 @@ guidetolerance="10" inkscape:pageopacity="0" inkscape:pageshadow="2" - inkscape:window-width="720" - inkscape:window-height="480" + inkscape:window-width="1366" + inkscape:window-height="716" id="namedview10" showgrid="false" - inkscape:zoom="1.18" - inkscape:cx="100" + inkscape:zoom="2.74" + inkscape:cx="38.50365" inkscape:cy="100" inkscape:window-x="0" inkscape:window-y="26" - inkscape:window-maximized="0" + inkscape:window-maximized="1" inkscape:current-layer="Layer_1" /> \ No newline at end of file + style="fill:#ffffff" + transform="scale(-1,-1)" /> \ No newline at end of file diff --git a/img/startSE.svg b/img/startSE.svg index 68db7cb..524c442 100644 --- a/img/startSE.svg +++ b/img/startSE.svg @@ -29,37 +29,37 @@ guidetolerance="10" inkscape:pageopacity="0" inkscape:pageshadow="2" - inkscape:window-width="720" - inkscape:window-height="480" + inkscape:window-width="1366" + inkscape:window-height="716" id="namedview10" showgrid="false" - inkscape:zoom="1.18" - inkscape:cx="100" + inkscape:zoom="2.74" + inkscape:cx="38.50365" inkscape:cy="100" inkscape:window-x="0" inkscape:window-y="26" - inkscape:window-maximized="0" + inkscape:window-maximized="1" inkscape:current-layer="Layer_1" /> \ No newline at end of file + style="fill:#ffffff" + transform="matrix(-0.5,0.8660254,-0.8660254,-0.5,0,0)" /> \ No newline at end of file diff --git a/img/startSW.svg b/img/startSW.svg index 4bd7501..b2ab35c 100644 --- a/img/startSW.svg +++ b/img/startSW.svg @@ -29,37 +29,37 @@ guidetolerance="10" inkscape:pageopacity="0" inkscape:pageshadow="2" - inkscape:window-width="720" - inkscape:window-height="480" + inkscape:window-width="1366" + inkscape:window-height="716" id="namedview10" showgrid="false" - inkscape:zoom="1.18" - inkscape:cx="100" + inkscape:zoom="2.74" + inkscape:cx="38.50365" inkscape:cy="100" inkscape:window-x="0" inkscape:window-y="26" - inkscape:window-maximized="0" + inkscape:window-maximized="1" inkscape:current-layer="Layer_1" /> \ No newline at end of file + style="fill:#ffffff" + transform="matrix(-0.5,-0.8660254,0.8660254,-0.5,0,0)" /> \ No newline at end of file diff --git a/img/stop.svg b/img/stop.svg index 1eae700..c2eede1 100644 --- a/img/stop.svg +++ b/img/stop.svg @@ -1,9 +1,59 @@ - - - - - - - + + + +image/svg+xml \ No newline at end of file -- 2.44.1 From 5a2a23d7080929f0cb4656c01aecdcedec798dda Mon Sep 17 00:00:00 2001 From: Guerric Chupin Date: Mon, 27 Jun 2016 19:15:07 +0100 Subject: [PATCH 04/16] Click handling appears correct. However I don't know if it will still randomly hang from time to time or not. --- RMCA/GUI/Board.hs | 47 +++++++++++++++++++++++++++++++++++++++-------- RMCA/Main.hs | 1 + RMCA/Semantics.hs | 9 ++++++++- 3 files changed, 48 insertions(+), 9 deletions(-) diff --git a/RMCA/GUI/Board.hs b/RMCA/GUI/Board.hs index 30704e2..9794246 100644 --- a/RMCA/GUI/Board.hs +++ b/RMCA/GUI/Board.hs @@ -3,7 +3,9 @@ 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 @@ -26,6 +28,10 @@ data GUICell = GUICell { cellAction :: Action , asPh :: Bool } deriving(Show) +rotateGUICell g = g { cellAction = rotateAction $ cellAction g } + where rotateAction (ChDir b na d) = ChDir b na (nextDir d) + rotateAction x = x + newtype GUIBoard = GUIBoard { toGS :: GameState Int Tile Player GUICell } data Tile = Tile @@ -108,10 +114,7 @@ initGUIBoard :: GUIBoard initGUIBoard = GUIBoard GameState { curPlayer' = Player , boardPos = boardToTile - , boardPieces' = boardToPiece [] $ - makeBoard [((0,0), mkCell (ChDir True na NE)), - ((2,1), mkCellRpt (ChDir False na NW) 3), - ((0,2), mkCell (ChDir False na S))] + , boardPieces' = boardToPiece [] $ makeBoard [] } instance PlayableGame GUIBoard Int Tile Player GUICell where @@ -127,8 +130,6 @@ instance PlayableGame GUIBoard Int Tile Player GUICell where canMoveTo _ _ _ (x,y) = (x,y) `elem` validArea move guiBoard@(GUIBoard game) p iPos@(_,yi) (xf,yf) - | not (canMove guiBoard p iPos) = [] - | not (canMoveTo guiBoard p iPos fPos') = [] | iPos `elem` ctrlCoord = [ RemovePiece fPos' , AddPiece fPos' Player (nCell { cellAction = ctrlAction }) ] @@ -185,10 +186,13 @@ initGame = do return $ Game visualA initGUIBoard +-- Initializes a readable RV for the board and an readable-writable RV +-- for the playheads. Also installs some handlers for pieces modification. initBoardRV :: BIO.Board Int Tile (Player,GUICell) -> IO ( ReactiveFieldRead IO Board , ReactiveFieldReadWrite IO [PlayHead]) initBoardRV board@BIO.Board { boardPieces = gBoard@(GameBoard array) } = do + -- RV creation phMVar <- newCBMVar [] oldphMVar <- newCBMVar [] notBMVar <- mkClockRV 100 @@ -238,12 +242,39 @@ initBoardRV board@BIO.Board { boardPieces = gBoard@(GameBoard array) } = do ph = ReactiveFieldReadWrite setterP getterP notifierP return (b,ph) +clickHandling :: BIO.Board Int Tile (Player,GUICell) -> IO () +clickHandling board = do + state <- newEmptyMVar + boardOnPress board + (\iPos -> liftIO $ do + tryPutMVar state iPos + return True + ) + boardOnRelease board + (\fPos -> liftIO $ do + mp <- boardGetPiece fPos board + mstate <- tryTakeMVar state + when (fPos `elem` validArea && isJust mp && + maybe False (== fPos) mstate) $ do + boardSetPiece fPos (BF.second rotateGUICell $ + fromJust mp) board + return True + ) + + {- + boardOnPress board + (\i -> do + mp <- boardGetPiece i board + when (i `elem` validArea && isJust mp && fromJust mp == Inert) $ +-} + + fileToPixbuf :: IO [(FilePath,Pixbuf)] fileToPixbuf = mapM (\f -> let f' = "img/" ++ f in uncurry (liftM2 (,)) ( return f' , pixbufNewFromFile f' >>= \p -> pixbufScaleSimple p hexW hexW InterpBilinear )) - (["hexOn.png","hexOff.png","stop.svg","split.svg"] ++ + (["hexOn.png","hexOff.png","stop.svg","split.svg","absorb.svg"] ++ concat [["start" ++ show d ++ ".svg","ric" ++ show d ++ ".svg"] | d <- [N .. NW]]) @@ -254,7 +285,7 @@ actionToFile GUICell { cellAction = a case (a,ph) of (Inert,True) -> "img/hexOn.png" (Inert,False) -> "img/hexOff.png" - (Absorb,_) -> "img/stop.svg" + (Absorb,_) -> "img/absorb.svg" (Stop _,_) -> "img/stop.svg" (ChDir True _ d,_) -> "img/start" ++ show d ++ ".svg" (ChDir False _ d,_) -> "img/ric" ++ show d ++ ".svg" diff --git a/RMCA/Main.hs b/RMCA/Main.hs index efcb981..f8f2b81 100644 --- a/RMCA/Main.hs +++ b/RMCA/Main.hs @@ -179,6 +179,7 @@ main = do layer <- reactiveValueRead layerRV tempo <- reactiveValueRead tempoRV (boardRV, phRV) <- initBoardRV guiBoard + clickHandling guiBoard reactiveValueOnCanRead playRV (reactiveValueRead boardRV >>= reactiveValueWrite phRV . startHeads) reactiveValueOnCanRead stopRV $ reactiveValueWrite phRV [] diff --git a/RMCA/Semantics.hs b/RMCA/Semantics.hs index de62520..08c42a6 100644 --- a/RMCA/Semantics.hs +++ b/RMCA/Semantics.hs @@ -287,8 +287,15 @@ data Note = Note { -- Angle measured in multiples of 60 degrees. type Angle = Int -data Dir = N | NE | SE | S | SW | NW deriving (Enum, Eq, Show) +data Dir = N | NE | SE | S | SW | NW deriving (Enum, Bounded, Eq, Show) +predDir :: Dir -> Dir +predDir d | d == minBound = maxBound + | otherwise = pred d + +nextDir :: Dir -> Dir +nextDir d | d == maxBound = minBound + | otherwise = succ d turn :: Dir -> Angle -> Dir turn d a = toEnum ((fromEnum d + a) `mod` 6) -- 2.44.1 From 257f599656e080e0465f20acc4e7dbbb28e4fb7c Mon Sep 17 00:00:00 2001 From: Guerric Chupin Date: Tue, 28 Jun 2016 12:07:44 +0100 Subject: [PATCH 05/16] Added a few calls to postGUIAsync. --- CLOC.md | 6 ++--- RMCA/GUI/Board.hs | 29 +++++++++++---------- RMCA/Global/Clock.hs | 10 ++++---- RMCA/Main.hs | 56 ++++++++++++++++++++--------------------- RMCA/Translator/Note.hs | 2 +- 5 files changed, 51 insertions(+), 52 deletions(-) diff --git a/CLOC.md b/CLOC.md index 76709f8..41b0246 100644 --- a/CLOC.md +++ b/CLOC.md @@ -1,9 +1,9 @@ -cloc|https://github.com/AlDanial/cloc v 1.66 T=0.06 s (404.7 files/s, 32964.5 lines/s) +cloc|https://github.com/AlDanial/cloc v 1.66 T=0.09 s (299.7 files/s, 25153.0 lines/s) --- | --- Language|files|blank|comment|code :-------|-------:|-------:|-------:|-------: -Haskell|26|335|430|1353 +Haskell|26|341|439|1402 --------|--------|--------|--------|-------- -SUM:|26|335|430|1353 +SUM:|26|341|439|1402 diff --git a/RMCA/GUI/Board.hs b/RMCA/GUI/Board.hs index 9794246..d1d21d4 100644 --- a/RMCA/GUI/Board.hs +++ b/RMCA/GUI/Board.hs @@ -138,7 +138,7 @@ instance PlayableGame GUIBoard Int Tile Player GUICell where where fPos' | (xf `mod` 2 == 0 && yf `mod` 2 == 0) || (xf `mod` 2 /= 0 && yf `mod` 2 /= 0) = (xf,yf) - | otherwise = (xf,yf)-- (xf,yf+signum' (yf-yi)) + | otherwise = (xf,yf+signum' (yf-yi)) signum' x | x == 0 = 1 | otherwise = signum x @@ -194,7 +194,6 @@ initBoardRV :: BIO.Board Int Tile (Player,GUICell) initBoardRV board@BIO.Board { boardPieces = gBoard@(GameBoard array) } = do -- RV creation phMVar <- newCBMVar [] - oldphMVar <- newCBMVar [] notBMVar <- mkClockRV 100 let getterB :: IO Board getterB = do @@ -214,9 +213,7 @@ initBoardRV board@BIO.Board { boardPieces = gBoard@(GameBoard array) } = do setterP :: [PlayHead] -> IO () setterP lph = do - readCBMVar phMVar >>= writeCBMVar oldphMVar - writeCBMVar phMVar lph - oph <- readCBMVar oldphMVar + oph <- readCBMVar phMVar let phPosS = map phPos lph offPh :: PlayHead -> IO () offPh ph = do @@ -224,7 +221,7 @@ initBoardRV board@BIO.Board { boardPieces = gBoard@(GameBoard array) } = do piece <- boardGetPiece pos board when (isJust piece) $ do let (_,c) = fromJust piece - boardSetPiece pos (Player, c { asPh = pos `elem` phPosS }) board + boardSetPiece pos (Player, c { asPh = False }) board onPh :: PlayHead -> IO () onPh ph = do let pos = toGUICoords $ phPos ph @@ -232,8 +229,9 @@ initBoardRV board@BIO.Board { boardPieces = gBoard@(GameBoard array) } = do when (isJust piece) $ do let (_,c) = fromJust piece boardSetPiece pos (Player, c { asPh = True }) board - mapM_ offPh oph - mapM_ onPh lph + postGUIAsync $ mapM_ offPh oph + postGUIAsync $ mapM_ onPh lph + writeCBMVar phMVar lph notifierP :: IO () -> IO () notifierP = installCallbackCBMVar phMVar @@ -247,17 +245,18 @@ clickHandling board = do state <- newEmptyMVar boardOnPress board (\iPos -> liftIO $ do - tryPutMVar state iPos + postGUIAsync $ void $ tryPutMVar state iPos return True ) boardOnRelease board (\fPos -> liftIO $ do - mp <- boardGetPiece fPos board - mstate <- tryTakeMVar state - when (fPos `elem` validArea && isJust mp && - maybe False (== fPos) mstate) $ do - boardSetPiece fPos (BF.second rotateGUICell $ - fromJust mp) board + postGUIAsync $ do + mp <- boardGetPiece fPos board + mstate <- tryTakeMVar state + when (fPos `elem` validArea && isJust mp && + maybe False (== fPos) mstate) $ do + boardSetPiece fPos (BF.second rotateGUICell $ + fromJust mp) board return True ) diff --git a/RMCA/Global/Clock.hs b/RMCA/Global/Clock.hs index f791dbc..a664cc9 100644 --- a/RMCA/Global/Clock.hs +++ b/RMCA/Global/Clock.hs @@ -14,17 +14,17 @@ tempo = constant -- The initial value is arbitrary but never appears because the switch -- is immediate. metronome :: SF Tempo (Event Beat) -metronome = switch (repeatedly (tempoToDTime 60) () +metronome = switch (repeatedly (tempoToQNoteIvl 120) () &&& onChange') metronome' where metronome' :: Tempo -> SF Tempo (Event Beat) - metronome' t = switch (repeatedly (4 * tempoToDTime t) () + metronome' t = switch (repeatedly (tempoToQNoteIvl t) () &&& onChange) metronome' --- Tempo is the number of whole notes per minute. -tempoToDTime :: Tempo -> DTime -tempoToDTime = (15/) . fromIntegral +-- Tempo is the number of quarter notes per minute. +tempoToQNoteIvl :: Tempo -> DTime +tempoToQNoteIvl = (15/) . fromIntegral type TickingClock = (CBMVar (), ThreadId) diff --git a/RMCA/Main.hs b/RMCA/Main.hs index f8f2b81..b349037 100644 --- a/RMCA/Main.hs +++ b/RMCA/Main.hs @@ -1,35 +1,35 @@ -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables #-} module Main where -import Control.Concurrent -import Data.ReactiveValue -import FRP.Yampa -import Graphics.UI.Gtk -import Graphics.UI.Gtk.Reactive -import Hails.Yampa -import RMCA.Auxiliary.Concurrent -import RMCA.Auxiliary.RV -import RMCA.Global.Clock -import RMCA.GUI.Buttons -import RMCA.Layer.Board -import RMCA.Layer.Layer -import RMCA.Semantics -import RMCA.Translator.Jack -import RMCA.Translator.Message -import RMCA.Translator.Translator -import Graphics.UI.Gtk.Layout.BackgroundContainer -import RMCA.GUI.Board -import Graphics.UI.Gtk.Board.BoardLink +import Control.Concurrent +import Data.Array.IO +import Data.Array.MArray +import Data.ReactiveValue +import FRP.Yampa import Game.Board.BasicTurnGame -import Graphics.UI.Gtk.Board.TiledBoard -import Data.Array.MArray -import qualified Graphics.UI.Gtk.Board.TiledBoard as BIO -import Data.Array.IO - - -import Control.Monad -import Data.Ratio +import Graphics.UI.Gtk +import Graphics.UI.Gtk.Board.BoardLink +import Graphics.UI.Gtk.Board.TiledBoard +import qualified Graphics.UI.Gtk.Board.TiledBoard as BIO +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.Layer.Board +import RMCA.Layer.Layer +import RMCA.Semantics +import RMCA.Translator.Jack +import RMCA.Translator.Message +import RMCA.Translator.Translator + + +import Control.Monad +import Data.Ratio floatConv :: (ReactiveValueReadWrite a b m, Real c, Real b, Fractional c, Fractional b) => diff --git a/RMCA/Translator/Note.hs b/RMCA/Translator/Note.hs index e89b504..3b640e5 100644 --- a/RMCA/Translator/Note.hs +++ b/RMCA/Translator/Note.hs @@ -29,7 +29,7 @@ noteToMessages layTempo sr chan = , noteDur = d }) -> do nm <- noteOnToMessage chan -< n - let dt = fromRational (d * toRational (tempoToDTime layTempo)) + let dt = fromRational (d * toRational (tempoToQNoteIvl layTempo)) dn = floor $ dt * fromIntegral sr returnA -< [(t,nm),(t + dn,switchOnOff nm)] -- 2.44.1 From 2af0cb17382bfb04f22437aa130c2d13cd9322dd Mon Sep 17 00:00:00 2001 From: Guerric Chupin Date: Tue, 28 Jun 2016 12:22:47 +0100 Subject: [PATCH 06/16] Tiles are removable by dragging them outside. --- RMCA/GUI/Board.hs | 23 +++++++++++++++-------- 1 file changed, 15 insertions(+), 8 deletions(-) diff --git a/RMCA/GUI/Board.hs b/RMCA/GUI/Board.hs index d1d21d4..decb998 100644 --- a/RMCA/GUI/Board.hs +++ b/RMCA/GUI/Board.hs @@ -86,7 +86,8 @@ ctrlPieces = [(xMax+2,y,Player,GUICell { cellAction = action -- for placing the control pieces. , (y,action) <- zip [ yMin+4,yMin+8..] actions] -ctrlCoord = map (\(x,y,_,_) -> (x,y)) ctrlPieces +ctrlCoords :: [(Int,Int)] +ctrlCoords = map (\(x,y,_,_) -> (x,y)) ctrlPieces boardToPiece :: [PlayHead] -> Board -> [(Int,Int,Player,GUICell)] boardToPiece ph = (++ ctrlPieces) . map placePiece . @@ -104,6 +105,9 @@ validArea :: [(Int,Int)] validArea = filter (onBoard . fromGUICoords) $ map (\(x,y,_,_) -> (x,y)) $ boardToPiece [] $ makeBoard [] +outGUIBoard :: (Int,Int) -> Bool +outGUIBoard (xf,yf) = xf < xMin || xf > xMax || yf < yMin || yf > yMax + na = NoteAttr { naArt = Accent13, naDur = 1 % 1, @@ -127,14 +131,17 @@ instance PlayableGame GUIBoard Int Tile Player GUICell where , GUICell { cellAction = Inert } <- p = False | Nothing <- getPieceAt game (x,y) = False | otherwise = True - canMoveTo _ _ _ (x,y) = (x,y) `elem` validArea - - move guiBoard@(GUIBoard game) p iPos@(_,yi) (xf,yf) - | iPos `elem` ctrlCoord = [ RemovePiece fPos' - , AddPiece fPos' Player (nCell { cellAction = ctrlAction }) - ] + canMoveTo _ _ _ fPos = fPos `elem` validArea + || outGUIBoard fPos + + move guiBoard@(GUIBoard game) p iPos@(_,yi) fPos@(xf,yf) + | iPos `elem` ctrlCoords = [ RemovePiece fPos' + , AddPiece fPos' Player + (nCell { cellAction = ctrlAction }) ] + | outGUIBoard fPos = [ RemovePiece iPos + , AddPiece iPos Player nCell ] | otherwise = [ MovePiece iPos fPos' - , AddPiece iPos Player nCell] + , AddPiece iPos Player nCell ] where fPos' | (xf `mod` 2 == 0 && yf `mod` 2 == 0) || (xf `mod` 2 /= 0 && yf `mod` 2 /= 0) = (xf,yf) -- 2.44.1 From 946d3cc7dfd3c5c5f2637a6deca6e1c9c9f1f0bf Mon Sep 17 00:00:00 2001 From: Guerric Chupin Date: Tue, 28 Jun 2016 13:24:47 +0100 Subject: [PATCH 07/16] Now using cabal. --- .gitignore | 4 ++- ChangeLog.md | 5 ++++ RMCA.cabal | 28 ++++++++++++++++++++ Setup.hs | 2 ++ {RMCA => src/RMCA}/Auxiliary/Auxiliary.hs | 0 {RMCA => src/RMCA}/Auxiliary/Concurrent.hs | 0 {RMCA => src/RMCA}/Auxiliary/Curry.hs | 0 {RMCA => src/RMCA}/Auxiliary/RV.hs | 0 {RMCA => src/RMCA}/GUI/Board.hs | 26 +++++++++--------- {RMCA => src/RMCA}/GUI/Buttons.hs | 0 {RMCA => src/RMCA}/GUI/GUI.hs | 0 {RMCA => src/RMCA}/GUI/Shapes.hs | 0 {RMCA => src/RMCA}/Global/Clock.hs | 0 {RMCA => src/RMCA}/Layer/Board.hs | 0 {RMCA => src/RMCA}/Layer/Layer.hs | 0 {RMCA => src/RMCA}/Layer/PlayHead.hs | 0 {RMCA => src/RMCA}/Main.hs | 0 {RMCA => src/RMCA}/Semantics.hs | 0 {RMCA => src/RMCA}/Translator/Controller.hs | 0 {RMCA => src/RMCA}/Translator/Filter.hs | 0 {RMCA => src/RMCA}/Translator/Jack.hs | 0 {RMCA => src/RMCA}/Translator/Message.hs | 0 {RMCA => src/RMCA}/Translator/Note.hs | 0 {RMCA => src/RMCA}/Translator/RV.hs | 0 {RMCA => src/RMCA}/Translator/SortMessage.hs | 0 {RMCA => src/RMCA}/Translator/Translator.hs | 0 {RMCA => src/RMCA}/Unknown/Arpeggiated.hs | 0 {RMCA => src/RMCA}/Unknown/Auxiliary.hs | 0 {RMCA => src/RMCA}/Unknown/AvgInt.hs | 0 {RMCA => src/RMCA}/Unknown/AvgIvl.hs | 0 {RMCA => src/RMCA}/Unknown/ClientState.hs | 0 {RMCA => src/RMCA}/Unknown/MIDI.hs | 0 {RMCA => src/RMCA}/Unknown/Reactimation.hs | 0 {RMCA => src/RMCA}/Unknown/Reactogon.hs | 0 {RMCA => src/RMCA}/Unknown/Shared.hs | 0 {RMCA => src/RMCA}/Unknown/Time.hs | 0 {RMCA => src/RMCA}/tests/testArpeggiated.hs | 0 {RMCA => src/RMCA}/tests/testAvgInt.hs | 0 {RMCA => src/RMCA}/tests/testClock.hs | 0 {RMCA => src/RMCA}/tests/testOnChange.hs | 0 40 files changed, 52 insertions(+), 13 deletions(-) create mode 100644 ChangeLog.md create mode 100644 RMCA.cabal create mode 100644 Setup.hs rename {RMCA => src/RMCA}/Auxiliary/Auxiliary.hs (100%) rename {RMCA => src/RMCA}/Auxiliary/Concurrent.hs (100%) rename {RMCA => src/RMCA}/Auxiliary/Curry.hs (100%) rename {RMCA => src/RMCA}/Auxiliary/RV.hs (100%) rename {RMCA => src/RMCA}/GUI/Board.hs (94%) rename {RMCA => src/RMCA}/GUI/Buttons.hs (100%) rename {RMCA => src/RMCA}/GUI/GUI.hs (100%) rename {RMCA => src/RMCA}/GUI/Shapes.hs (100%) rename {RMCA => src/RMCA}/Global/Clock.hs (100%) rename {RMCA => src/RMCA}/Layer/Board.hs (100%) rename {RMCA => src/RMCA}/Layer/Layer.hs (100%) rename {RMCA => src/RMCA}/Layer/PlayHead.hs (100%) rename {RMCA => src/RMCA}/Main.hs (100%) rename {RMCA => src/RMCA}/Semantics.hs (100%) rename {RMCA => src/RMCA}/Translator/Controller.hs (100%) rename {RMCA => src/RMCA}/Translator/Filter.hs (100%) rename {RMCA => src/RMCA}/Translator/Jack.hs (100%) rename {RMCA => src/RMCA}/Translator/Message.hs (100%) rename {RMCA => src/RMCA}/Translator/Note.hs (100%) rename {RMCA => src/RMCA}/Translator/RV.hs (100%) rename {RMCA => src/RMCA}/Translator/SortMessage.hs (100%) rename {RMCA => src/RMCA}/Translator/Translator.hs (100%) rename {RMCA => src/RMCA}/Unknown/Arpeggiated.hs (100%) rename {RMCA => src/RMCA}/Unknown/Auxiliary.hs (100%) rename {RMCA => src/RMCA}/Unknown/AvgInt.hs (100%) rename {RMCA => src/RMCA}/Unknown/AvgIvl.hs (100%) rename {RMCA => src/RMCA}/Unknown/ClientState.hs (100%) rename {RMCA => src/RMCA}/Unknown/MIDI.hs (100%) rename {RMCA => src/RMCA}/Unknown/Reactimation.hs (100%) rename {RMCA => src/RMCA}/Unknown/Reactogon.hs (100%) rename {RMCA => src/RMCA}/Unknown/Shared.hs (100%) rename {RMCA => src/RMCA}/Unknown/Time.hs (100%) rename {RMCA => src/RMCA}/tests/testArpeggiated.hs (100%) rename {RMCA => src/RMCA}/tests/testAvgInt.hs (100%) rename {RMCA => src/RMCA}/tests/testClock.hs (100%) rename {RMCA => src/RMCA}/tests/testOnChange.hs (100%) diff --git a/.gitignore b/.gitignore index e049daf..e4389de 100644 --- a/.gitignore +++ b/.gitignore @@ -23,4 +23,6 @@ QUESTIONS.md *.#* html/ /GUI/ -/img/Shapes.hs \ No newline at end of file +/img/Shapes.hs +/dist +*.save* \ No newline at end of file diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 index 0000000..5b303fd --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for reactogon + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/RMCA.cabal b/RMCA.cabal new file mode 100644 index 0000000..cb19cc4 --- /dev/null +++ b/RMCA.cabal @@ -0,0 +1,28 @@ +-- Initial reactogon.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: RMCA +version: 0.1.0.0 +-- synopsis: +-- description: +homepage: https://gitlab.com/chupin/reactogon +-- license: +license-file: LICENSE +author: Guerric Chupin +maintainer: guerric.chupin@gmail.com +-- copyright: +-- category: +build-type: Simple +extra-source-files: ChangeLog.md, README.md +cabal-version: >=1.10 +data-files: img/*.png, img/*.svg + +executable RMCA + main-is: RMCA/Main.hs + -- other-modules: + other-extensions: MultiParamTypeClasses, ScopedTypeVariables, Arrows, FlexibleInstances, TypeSynonymInstances, FlexibleContexts, GeneralizedNewtypeDeriving + build-depends: base >=4.8 && <4.10, array >=0.5 && <0.6, cairo >=0.13 && <0.14, keera-hails-reactivevalues >=0.2 && <0.3, Yampa >=0.10 && <0.11, gtk-helpers >=0.0 && <0.1, gtk >=0.14 && <0.15, keera-hails-reactive-gtk >=0.3 && <0.4, keera-hails-reactive-yampa >=0.0 && <0.1, containers >=0.5 && <0.6, jack >=0.7 && <0.8, midi >=0.2 && <0.3, explicit-exception >=0.1 && <0.2, transformers >=0.4 && <0.6, event-list >=0.1 && <0.2, keera-callbacks >=0.1 && <0.2, glib >=0.13 && <0.14, directory >=1.2 && <1.3, process >=1.4 && <1.5 + hs-source-dirs: src + build-tools: hsc2hs + default-language: Haskell2010 + ghc-options: -O2 -threaded diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/RMCA/Auxiliary/Auxiliary.hs b/src/RMCA/Auxiliary/Auxiliary.hs similarity index 100% rename from RMCA/Auxiliary/Auxiliary.hs rename to src/RMCA/Auxiliary/Auxiliary.hs diff --git a/RMCA/Auxiliary/Concurrent.hs b/src/RMCA/Auxiliary/Concurrent.hs similarity index 100% rename from RMCA/Auxiliary/Concurrent.hs rename to src/RMCA/Auxiliary/Concurrent.hs diff --git a/RMCA/Auxiliary/Curry.hs b/src/RMCA/Auxiliary/Curry.hs similarity index 100% rename from RMCA/Auxiliary/Curry.hs rename to src/RMCA/Auxiliary/Curry.hs diff --git a/RMCA/Auxiliary/RV.hs b/src/RMCA/Auxiliary/RV.hs similarity index 100% rename from RMCA/Auxiliary/RV.hs rename to src/RMCA/Auxiliary/RV.hs diff --git a/RMCA/GUI/Board.hs b/src/RMCA/GUI/Board.hs similarity index 94% rename from RMCA/GUI/Board.hs rename to src/RMCA/GUI/Board.hs index decb998..6a5ad84 100644 --- a/RMCA/GUI/Board.hs +++ b/src/RMCA/GUI/Board.hs @@ -20,6 +20,7 @@ import Graphics.UI.Gtk hiding (Action) import Graphics.UI.Gtk.Board.BoardLink import Graphics.UI.Gtk.Board.TiledBoard hiding (Board) import qualified Graphics.UI.Gtk.Board.TiledBoard as BIO +import Paths_RMCA import RMCA.Global.Clock import RMCA.Semantics @@ -276,10 +277,12 @@ clickHandling board = do fileToPixbuf :: IO [(FilePath,Pixbuf)] -fileToPixbuf = mapM (\f -> let f' = "img/" ++ f in uncurry (liftM2 (,)) - ( return f' - , pixbufNewFromFile f' >>= - \p -> pixbufScaleSimple p hexW hexW InterpBilinear )) +fileToPixbuf = mapM (\f -> let f' = ("img/" ++ f) in + uncurry (liftM2 (,)) + ( return f' + , getDataFileName f' >>= + \f'' -> pixbufNewFromFile f'' >>= + \p -> pixbufScaleSimple p hexW hexW InterpBilinear)) (["hexOn.png","hexOff.png","stop.svg","split.svg","absorb.svg"] ++ concat [["start" ++ show d ++ ".svg","ric" ++ show d ++ ".svg"] | d <- [N .. NW]]) @@ -288,11 +291,10 @@ actionToFile :: GUICell -> FilePath actionToFile GUICell { cellAction = a , asPh = ph } = - case (a,ph) of - (Inert,True) -> "img/hexOn.png" - (Inert,False) -> "img/hexOff.png" - (Absorb,_) -> "img/absorb.svg" - (Stop _,_) -> "img/stop.svg" - (ChDir True _ d,_) -> "img/start" ++ show d ++ ".svg" - (ChDir False _ d,_) -> "img/ric" ++ show d ++ ".svg" - (Split _,_) -> "img/split.svg" + case a of + Inert -> "img/hexO" ++ (if ph then "n" else "ff") ++ ".png" + Absorb -> "img/absorb.svg" + Stop _ -> "img/stop.svg" + ChDir True _ d -> "img/start" ++ show d ++ ".svg" + ChDir False _ d -> "img/ric" ++ show d ++ ".svg" + Split _ -> "img/split.svg" diff --git a/RMCA/GUI/Buttons.hs b/src/RMCA/GUI/Buttons.hs similarity index 100% rename from RMCA/GUI/Buttons.hs rename to src/RMCA/GUI/Buttons.hs diff --git a/RMCA/GUI/GUI.hs b/src/RMCA/GUI/GUI.hs similarity index 100% rename from RMCA/GUI/GUI.hs rename to src/RMCA/GUI/GUI.hs diff --git a/RMCA/GUI/Shapes.hs b/src/RMCA/GUI/Shapes.hs similarity index 100% rename from RMCA/GUI/Shapes.hs rename to src/RMCA/GUI/Shapes.hs diff --git a/RMCA/Global/Clock.hs b/src/RMCA/Global/Clock.hs similarity index 100% rename from RMCA/Global/Clock.hs rename to src/RMCA/Global/Clock.hs diff --git a/RMCA/Layer/Board.hs b/src/RMCA/Layer/Board.hs similarity index 100% rename from RMCA/Layer/Board.hs rename to src/RMCA/Layer/Board.hs diff --git a/RMCA/Layer/Layer.hs b/src/RMCA/Layer/Layer.hs similarity index 100% rename from RMCA/Layer/Layer.hs rename to src/RMCA/Layer/Layer.hs diff --git a/RMCA/Layer/PlayHead.hs b/src/RMCA/Layer/PlayHead.hs similarity index 100% rename from RMCA/Layer/PlayHead.hs rename to src/RMCA/Layer/PlayHead.hs diff --git a/RMCA/Main.hs b/src/RMCA/Main.hs similarity index 100% rename from RMCA/Main.hs rename to src/RMCA/Main.hs diff --git a/RMCA/Semantics.hs b/src/RMCA/Semantics.hs similarity index 100% rename from RMCA/Semantics.hs rename to src/RMCA/Semantics.hs diff --git a/RMCA/Translator/Controller.hs b/src/RMCA/Translator/Controller.hs similarity index 100% rename from RMCA/Translator/Controller.hs rename to src/RMCA/Translator/Controller.hs diff --git a/RMCA/Translator/Filter.hs b/src/RMCA/Translator/Filter.hs similarity index 100% rename from RMCA/Translator/Filter.hs rename to src/RMCA/Translator/Filter.hs diff --git a/RMCA/Translator/Jack.hs b/src/RMCA/Translator/Jack.hs similarity index 100% rename from RMCA/Translator/Jack.hs rename to src/RMCA/Translator/Jack.hs diff --git a/RMCA/Translator/Message.hs b/src/RMCA/Translator/Message.hs similarity index 100% rename from RMCA/Translator/Message.hs rename to src/RMCA/Translator/Message.hs diff --git a/RMCA/Translator/Note.hs b/src/RMCA/Translator/Note.hs similarity index 100% rename from RMCA/Translator/Note.hs rename to src/RMCA/Translator/Note.hs diff --git a/RMCA/Translator/RV.hs b/src/RMCA/Translator/RV.hs similarity index 100% rename from RMCA/Translator/RV.hs rename to src/RMCA/Translator/RV.hs diff --git a/RMCA/Translator/SortMessage.hs b/src/RMCA/Translator/SortMessage.hs similarity index 100% rename from RMCA/Translator/SortMessage.hs rename to src/RMCA/Translator/SortMessage.hs diff --git a/RMCA/Translator/Translator.hs b/src/RMCA/Translator/Translator.hs similarity index 100% rename from RMCA/Translator/Translator.hs rename to src/RMCA/Translator/Translator.hs diff --git a/RMCA/Unknown/Arpeggiated.hs b/src/RMCA/Unknown/Arpeggiated.hs similarity index 100% rename from RMCA/Unknown/Arpeggiated.hs rename to src/RMCA/Unknown/Arpeggiated.hs diff --git a/RMCA/Unknown/Auxiliary.hs b/src/RMCA/Unknown/Auxiliary.hs similarity index 100% rename from RMCA/Unknown/Auxiliary.hs rename to src/RMCA/Unknown/Auxiliary.hs diff --git a/RMCA/Unknown/AvgInt.hs b/src/RMCA/Unknown/AvgInt.hs similarity index 100% rename from RMCA/Unknown/AvgInt.hs rename to src/RMCA/Unknown/AvgInt.hs diff --git a/RMCA/Unknown/AvgIvl.hs b/src/RMCA/Unknown/AvgIvl.hs similarity index 100% rename from RMCA/Unknown/AvgIvl.hs rename to src/RMCA/Unknown/AvgIvl.hs diff --git a/RMCA/Unknown/ClientState.hs b/src/RMCA/Unknown/ClientState.hs similarity index 100% rename from RMCA/Unknown/ClientState.hs rename to src/RMCA/Unknown/ClientState.hs diff --git a/RMCA/Unknown/MIDI.hs b/src/RMCA/Unknown/MIDI.hs similarity index 100% rename from RMCA/Unknown/MIDI.hs rename to src/RMCA/Unknown/MIDI.hs diff --git a/RMCA/Unknown/Reactimation.hs b/src/RMCA/Unknown/Reactimation.hs similarity index 100% rename from RMCA/Unknown/Reactimation.hs rename to src/RMCA/Unknown/Reactimation.hs diff --git a/RMCA/Unknown/Reactogon.hs b/src/RMCA/Unknown/Reactogon.hs similarity index 100% rename from RMCA/Unknown/Reactogon.hs rename to src/RMCA/Unknown/Reactogon.hs diff --git a/RMCA/Unknown/Shared.hs b/src/RMCA/Unknown/Shared.hs similarity index 100% rename from RMCA/Unknown/Shared.hs rename to src/RMCA/Unknown/Shared.hs diff --git a/RMCA/Unknown/Time.hs b/src/RMCA/Unknown/Time.hs similarity index 100% rename from RMCA/Unknown/Time.hs rename to src/RMCA/Unknown/Time.hs diff --git a/RMCA/tests/testArpeggiated.hs b/src/RMCA/tests/testArpeggiated.hs similarity index 100% rename from RMCA/tests/testArpeggiated.hs rename to src/RMCA/tests/testArpeggiated.hs diff --git a/RMCA/tests/testAvgInt.hs b/src/RMCA/tests/testAvgInt.hs similarity index 100% rename from RMCA/tests/testAvgInt.hs rename to src/RMCA/tests/testAvgInt.hs diff --git a/RMCA/tests/testClock.hs b/src/RMCA/tests/testClock.hs similarity index 100% rename from RMCA/tests/testClock.hs rename to src/RMCA/tests/testClock.hs diff --git a/RMCA/tests/testOnChange.hs b/src/RMCA/tests/testOnChange.hs similarity index 100% rename from RMCA/tests/testOnChange.hs rename to src/RMCA/tests/testOnChange.hs -- 2.44.1 From 98a8180a35001a260d69a80118b95d6d2db09dff Mon Sep 17 00:00:00 2001 From: Guerric Chupin Date: Tue, 28 Jun 2016 19:09:00 +0100 Subject: [PATCH 08/16] Minor bug correction in tile moving. --- src/RMCA/GUI/Board.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/RMCA/GUI/Board.hs b/src/RMCA/GUI/Board.hs index 6a5ad84..b7a5817 100644 --- a/src/RMCA/GUI/Board.hs +++ b/src/RMCA/GUI/Board.hs @@ -136,11 +136,12 @@ instance PlayableGame GUIBoard Int Tile Player GUICell where || outGUIBoard fPos move guiBoard@(GUIBoard game) p iPos@(_,yi) fPos@(xf,yf) + | outGUIBoard iPos && outGUIBoard fPos = [] + | outGUIBoard fPos = [ RemovePiece iPos + , AddPiece iPos Player nCell ] | iPos `elem` ctrlCoords = [ RemovePiece fPos' , AddPiece fPos' Player (nCell { cellAction = ctrlAction }) ] - | outGUIBoard fPos = [ RemovePiece iPos - , AddPiece iPos Player nCell ] | otherwise = [ MovePiece iPos fPos' , AddPiece iPos Player nCell ] where fPos' -- 2.44.1 From d54f059b9ba93c239cea04362dee6729fccd3f49 Mon Sep 17 00:00:00 2001 From: Guerric Chupin Date: Wed, 29 Jun 2016 15:05:55 +0100 Subject: [PATCH 09/16] Unstable and non working setting display. --- src/RMCA/Auxiliary/RV.hs | 7 ++++ src/RMCA/GUI/Board.hs | 27 +++++++++++--- src/RMCA/GUI/GUI.hs | 1 - src/RMCA/GUI/Settings.hs | 79 ++++++++++++++++++++++++++++++++++++++++ src/RMCA/Main.hs | 66 ++++++++++++++++++--------------- src/RMCA/Semantics.hs | 6 +-- 6 files changed, 146 insertions(+), 40 deletions(-) delete mode 100644 src/RMCA/GUI/GUI.hs create mode 100644 src/RMCA/GUI/Settings.hs diff --git a/src/RMCA/Auxiliary/RV.hs b/src/RMCA/Auxiliary/RV.hs index 79095d7..c5acdab 100644 --- a/src/RMCA/Auxiliary/RV.hs +++ b/src/RMCA/Auxiliary/RV.hs @@ -35,6 +35,13 @@ onTick notif rv = ReactiveFieldRead getter notifier notifier cb = do reactiveValueOnCanRead notif cb reactiveValueOnCanRead rv cb + +addHandlerR :: (ReactiveValueRead a b m) => + a + -> (m () -> m()) + -> ReactiveFieldRead m b +addHandlerR x h = ReactiveFieldRead (reactiveValueRead x) + (\p -> reactiveValueOnCanRead x p >> h p) {- notif ^:> rv = reactiveValueOnCanRead notif (reactiveValueOnCanRead rv (return ())) diff --git a/src/RMCA/GUI/Board.hs b/src/RMCA/GUI/Board.hs index b7a5817..b75cd67 100644 --- a/src/RMCA/GUI/Board.hs +++ b/src/RMCA/GUI/Board.hs @@ -35,6 +35,8 @@ rotateGUICell g = g { cellAction = rotateAction $ cellAction g } newtype GUIBoard = GUIBoard { toGS :: GameState Int Tile Player GUICell } +type IOBoard = BIO.Board Int Tile (Player,GUICell) + data Tile = Tile data Player = Player deriving(Show) @@ -115,6 +117,12 @@ na = NoteAttr { naOrn = Ornaments Nothing [] NoSlide } +inertCell :: GUICell +inertCell = GUICell { cellAction = Inert + , repeatCount = 1 + , asPh = False + } + initGUIBoard :: GUIBoard initGUIBoard = GUIBoard GameState { curPlayer' = Player @@ -158,9 +166,6 @@ instance PlayableGame GUIBoard Int Tile Player GUICell where , asPh = ph } | otherwise = inertCell - where inertCell = GUICell { cellAction = Inert - , repeatCount = 1 - , asPh = False} applyChange (GUIBoard game) (AddPiece pos@(x,y) Player piece) = GUIBoard $ game { boardPieces' = bp' } @@ -199,14 +204,15 @@ initGame = do -- for the playheads. Also installs some handlers for pieces modification. 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 array) } = do +initBoardRV board@BIO.Board { boardPieces = gBoard@(GameBoard gArray) } = do -- RV creation phMVar <- newCBMVar [] notBMVar <- mkClockRV 100 let getterB :: IO Board getterB = do - (boardArray :: [((Int,Int),Maybe (Player,GUICell))]) <- getAssocs array + (boardArray :: [((Int,Int),Maybe (Player,GUICell))]) <- getAssocs gArray let board = makeBoard $ map (BF.first fromGUICoords . BF.second ((\(_,c) -> (cellAction c,repeatCount c)) . @@ -247,7 +253,16 @@ initBoardRV board@BIO.Board { boardPieces = gBoard@(GameBoard array) } = do b = ReactiveFieldRead getterB notifierB ph = ReactiveFieldReadWrite setterP getterP notifierP - return (b,ph) + + setterW :: (Int,Int) -> GUICell -> IO () + setterW i g = postGUIAsync $ boardSetPiece i (Player,g) board + + arrW :: Array Pos (ReactiveFieldWrite IO GUICell) + arrW = array (minimum validArea, maximum validArea) + [(i, ReactiveFieldWrite (setterW i)) + | i <- (validArea :: [(Int,Int)])] + + return (b,arrW,ph) clickHandling :: BIO.Board Int Tile (Player,GUICell) -> IO () clickHandling board = do diff --git a/src/RMCA/GUI/GUI.hs b/src/RMCA/GUI/GUI.hs deleted file mode 100644 index df71d6c..0000000 --- a/src/RMCA/GUI/GUI.hs +++ /dev/null @@ -1 +0,0 @@ -module RMCA.GUI.GUI where diff --git a/src/RMCA/GUI/Settings.hs b/src/RMCA/GUI/Settings.hs new file mode 100644 index 0000000..9e613f5 --- /dev/null +++ b/src/RMCA/GUI/Settings.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module RMCA.GUI.Settings where + +import Control.Monad +import Data.Array +import Data.Maybe +import Data.ReactiveValue +import Data.String +import Data.Tuple +import Graphics.UI.Gtk +import Graphics.UI.Gtk.Board.TiledBoard hiding (Board) +import Graphics.UI.Gtk.Reactive +import RMCA.Auxiliary.RV +import RMCA.GUI.Board +import RMCA.Semantics + +comboBoxIndexRV :: (ComboBoxClass box) => + box -> ReactiveFieldReadWrite IO Int +comboBoxIndexRV box = ReactiveFieldReadWrite setter getter notifier + where getter = comboBoxGetActive box + setter = comboBoxSetActive box + notifier = void . on box changed + +pieceButtons :: Array Pos (ReactiveFieldWrite IO GUICell) + -> IOBoard + -> VBox + -> IO VBox +pieceButtons rvArray board pieceBox = do + naBox <- vBoxNew False 10 + + -- Articulation box + artCombo <- comboBoxNewText + artIndex <- mapM (\art -> do i <- comboBoxAppendText artCombo + (fromString $ show art) + return (art,i)) [NoAccent ..] + comboBoxSetActive artCombo 0 + boxPackStart naBox artCombo PackNatural 10 + let indexToArt i = fromMaybe NoAccent $ lookup i $ map swap artIndex + artToIndex a = fromMaybe (-1) $ lookup a artIndex + artComboRV = liftRW (bijection (indexToArt,artToIndex)) $ + comboBoxIndexRV artCombo + + -- Slide box + slideCombo <- comboBoxNewText + slideIndex <- mapM (\sli -> do i <- comboBoxAppendText slideCombo + (fromString $ show sli) + return (sli,i)) [NoSlide ..] + comboBoxSetActive slideCombo 0 + boxPackStart naBox slideCombo PackNatural 10 + let indexToSlide i = fromMaybe NoSlide $ lookup i $ map swap slideIndex + slideToIndex s = fromMaybe (-1) $ lookup s slideIndex + slideComboRV = liftRW (bijection (indexToSlide,slideToIndex)) $ + comboBoxIndexRV slideCombo + + let displayPieceInfo :: (Int,Int) -> IO () + displayPieceInfo i = do + print i + when (i `elem` validArea) $ do + let pieceRV = rvArray ! i + piece <- boardGetPiece i board + when (isJust piece) $ do + setRV <- newCBMVarRW $ snd $ fromJust piece + setRV =:> pieceRV + reactiveValueOnCanRead setRV $ updateNaBox $ snd $ fromJust piece + 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 + + boardOnClick board displayPieceInfo + boxPackStart pieceBox naBox PackNatural 10 + print "Coucou !" + return pieceBox diff --git a/src/RMCA/Main.hs b/src/RMCA/Main.hs index b349037..92f8cf4 100644 --- a/src/RMCA/Main.hs +++ b/src/RMCA/Main.hs @@ -2,34 +2,36 @@ module Main where -import Control.Concurrent -import Data.Array.IO -import Data.Array.MArray -import Data.ReactiveValue -import FRP.Yampa -import Game.Board.BasicTurnGame -import Graphics.UI.Gtk -import Graphics.UI.Gtk.Board.BoardLink -import Graphics.UI.Gtk.Board.TiledBoard -import qualified Graphics.UI.Gtk.Board.TiledBoard as BIO -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.Layer.Board -import RMCA.Layer.Layer -import RMCA.Semantics -import RMCA.Translator.Jack -import RMCA.Translator.Message -import RMCA.Translator.Translator - - -import Control.Monad -import Data.Ratio +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 +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) => @@ -178,7 +180,7 @@ main = do -- Board setup layer <- reactiveValueRead layerRV tempo <- reactiveValueRead tempoRV - (boardRV, phRV) <- initBoardRV guiBoard + (boardRV, pieceArrRV, phRV) <- initBoardRV guiBoard clickHandling guiBoard reactiveValueOnCanRead playRV (reactiveValueRead boardRV >>= reactiveValueWrite phRV . startHeads) @@ -203,6 +205,10 @@ main = do -- Jack setup forkIO $ jackSetup tempoRV (constR 0) boardQueue widgetShowAll window + -- Piece characteristic + --pieceBox <- pieceButtons pieceArrRV guiBoard =<< vBoxNew False 10 + ------------------------------------------------------------ + + boxPackStart settingsBox pieceBox PackNatural 10 onDestroy window mainQuit mainGUI - --return () diff --git a/src/RMCA/Semantics.hs b/src/RMCA/Semantics.hs index 08c42a6..4deb830 100644 --- a/src/RMCA/Semantics.hs +++ b/src/RMCA/Semantics.hs @@ -186,7 +186,7 @@ data Articulation = NoAccent | Accent13 | Accent14 | Accent24 - deriving (Eq, Show) + deriving (Eq, Show, Enum) accentStrength = 1.2 @@ -239,7 +239,7 @@ data Ornaments = Ornaments { ornSlide :: SlideType } deriving Show -data SlideType = NoSlide | SlideUp | SlideDn deriving (Eq, Show) +data SlideType = NoSlide | SlideUp | SlideDn deriving (Eq, Show, Enum) noOrn :: Ornaments noOrn = Ornaments { ornPC = Nothing @@ -332,7 +332,7 @@ data Action = Inert -- No action, play heads move through. | Stop NoteAttr -- Play note then remove play head. | ChDir Bool NoteAttr Dir -- Play note then change direction. | Split NoteAttr -- Play note then split head into five. - deriving Show + deriving (Show) -- Cells -- 2.44.1 From 821ca54fcb560151e8c2e3f3bededb5e78b41d11 Mon Sep 17 00:00:00 2001 From: Guerric Chupin Date: Wed, 29 Jun 2016 15:53:07 +0100 Subject: [PATCH 10/16] Piece settings are displayed correctly but cannot yet be updated. --- src/RMCA/GUI/Board.hs | 22 +--------- src/RMCA/GUI/Settings.hs | 95 +++++++++++++++++++++++----------------- src/RMCA/Main.hs | 2 +- 3 files changed, 59 insertions(+), 60 deletions(-) diff --git a/src/RMCA/GUI/Board.hs b/src/RMCA/GUI/Board.hs index b75cd67..eb51fcf 100644 --- a/src/RMCA/GUI/Board.hs +++ b/src/RMCA/GUI/Board.hs @@ -14,6 +14,8 @@ 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) @@ -264,26 +266,6 @@ initBoardRV board@BIO.Board { boardPieces = gBoard@(GameBoard gArray) } = do return (b,arrW,ph) -clickHandling :: BIO.Board Int Tile (Player,GUICell) -> IO () -clickHandling board = do - state <- newEmptyMVar - boardOnPress board - (\iPos -> liftIO $ do - postGUIAsync $ void $ tryPutMVar state iPos - return True - ) - boardOnRelease board - (\fPos -> liftIO $ do - postGUIAsync $ do - mp <- boardGetPiece fPos board - mstate <- tryTakeMVar state - when (fPos `elem` validArea && isJust mp && - maybe False (== fPos) mstate) $ do - boardSetPiece fPos (BF.second rotateGUICell $ - fromJust mp) board - return True - ) - {- boardOnPress board (\i -> do diff --git a/src/RMCA/GUI/Settings.hs b/src/RMCA/GUI/Settings.hs index 9e613f5..bbde293 100644 --- a/src/RMCA/GUI/Settings.hs +++ b/src/RMCA/GUI/Settings.hs @@ -2,18 +2,21 @@ module RMCA.GUI.Settings where -import Control.Monad -import Data.Array -import Data.Maybe -import Data.ReactiveValue -import Data.String -import Data.Tuple -import Graphics.UI.Gtk -import Graphics.UI.Gtk.Board.TiledBoard hiding (Board) -import Graphics.UI.Gtk.Reactive -import RMCA.Auxiliary.RV -import RMCA.GUI.Board -import RMCA.Semantics +import Control.Concurrent.MVar +import Control.Monad +import Control.Monad.IO.Class +import Data.Array +import qualified Data.Bifunctor as BF +import Data.Maybe +import Data.ReactiveValue +import Data.String +import Data.Tuple +import Graphics.UI.Gtk +import Graphics.UI.Gtk.Board.TiledBoard hiding (Board) +import Graphics.UI.Gtk.Reactive +import RMCA.Auxiliary.RV +import RMCA.GUI.Board +import RMCA.Semantics comboBoxIndexRV :: (ComboBoxClass box) => box -> ReactiveFieldReadWrite IO Int @@ -22,12 +25,11 @@ comboBoxIndexRV box = ReactiveFieldReadWrite setter getter notifier setter = comboBoxSetActive box notifier = void . on box changed -pieceButtons :: Array Pos (ReactiveFieldWrite IO GUICell) - -> IOBoard - -> VBox - -> IO VBox -pieceButtons rvArray board pieceBox = do +clickHandling :: Array Pos (ReactiveFieldWrite IO GUICell) + -> IOBoard -> VBox -> IO VBox +clickHandling pieceArrRV board pieceBox = do naBox <- vBoxNew False 10 + boxPackStart pieceBox naBox PackNatural 10 -- Articulation box artCombo <- comboBoxNewText @@ -53,27 +55,42 @@ pieceButtons rvArray board pieceBox = do slideComboRV = liftRW (bijection (indexToSlide,slideToIndex)) $ comboBoxIndexRV slideCombo - let displayPieceInfo :: (Int,Int) -> IO () - displayPieceInfo i = do - print i - when (i `elem` validArea) $ do - let pieceRV = rvArray ! i - piece <- boardGetPiece i board - when (isJust piece) $ do - setRV <- newCBMVarRW $ snd $ fromJust piece - setRV =:> pieceRV - reactiveValueOnCanRead setRV $ updateNaBox $ snd $ fromJust piece - 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 - boardOnClick board displayPieceInfo - boxPackStart pieceBox naBox PackNatural 10 - print "Coucou !" + state <- newEmptyMVar + boardOnPress board + (\iPos -> liftIO $ do + postGUIAsync $ void $ tryPutMVar state iPos + return True + ) + boardOnRelease board + (\fPos -> liftIO $ do + postGUIAsync $ 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 + return True + ) + widgetShow pieceBox >> widgetShow naBox return pieceBox diff --git a/src/RMCA/Main.hs b/src/RMCA/Main.hs index 92f8cf4..623ac85 100644 --- a/src/RMCA/Main.hs +++ b/src/RMCA/Main.hs @@ -181,7 +181,6 @@ main = do layer <- reactiveValueRead layerRV tempo <- reactiveValueRead tempoRV (boardRV, pieceArrRV, phRV) <- initBoardRV guiBoard - clickHandling guiBoard reactiveValueOnCanRead playRV (reactiveValueRead boardRV >>= reactiveValueWrite phRV . startHeads) reactiveValueOnCanRead stopRV $ reactiveValueWrite phRV [] @@ -205,6 +204,7 @@ main = do -- Jack setup forkIO $ jackSetup tempoRV (constR 0) boardQueue widgetShowAll window + pieceBox <- clickHandling pieceArrRV guiBoard =<< vBoxNew False 10 -- Piece characteristic --pieceBox <- pieceButtons pieceArrRV guiBoard =<< vBoxNew False 10 ------------------------------------------------------------ -- 2.44.1 From 2a0dedd56325b24a4828a31efa596de58e156505 Mon Sep 17 00:00:00 2001 From: Guerric Chupin Date: Wed, 6 Jul 2016 11:37:07 +0100 Subject: [PATCH 11/16] Better formatting for .cabal file. --- RMCA.cabal | 28 ++++++++++++++++++++++++++-- 1 file changed, 26 insertions(+), 2 deletions(-) diff --git a/RMCA.cabal b/RMCA.cabal index cb19cc4..9f16a73 100644 --- a/RMCA.cabal +++ b/RMCA.cabal @@ -20,8 +20,32 @@ data-files: img/*.png, img/*.svg executable RMCA main-is: RMCA/Main.hs -- other-modules: - other-extensions: MultiParamTypeClasses, ScopedTypeVariables, Arrows, FlexibleInstances, TypeSynonymInstances, FlexibleContexts, GeneralizedNewtypeDeriving - build-depends: base >=4.8 && <4.10, array >=0.5 && <0.6, cairo >=0.13 && <0.14, keera-hails-reactivevalues >=0.2 && <0.3, Yampa >=0.10 && <0.11, gtk-helpers >=0.0 && <0.1, gtk >=0.14 && <0.15, keera-hails-reactive-gtk >=0.3 && <0.4, keera-hails-reactive-yampa >=0.0 && <0.1, containers >=0.5 && <0.6, jack >=0.7 && <0.8, midi >=0.2 && <0.3, explicit-exception >=0.1 && <0.2, transformers >=0.4 && <0.6, event-list >=0.1 && <0.2, keera-callbacks >=0.1 && <0.2, glib >=0.13 && <0.14, directory >=1.2 && <1.3, process >=1.4 && <1.5 + other-extensions: MultiParamTypeClasses + , ScopedTypeVariables + , Arrows + , FlexibleInstances + , TypeSynonymInstances + , FlexibleContexts + , GeneralizedNewtypeDeriving + build-depends: base >=4.8 && <4.10 + , array >=0.5 && <0.6 + , cairo >=0.13 && <0.14 + , keera-hails-reactivevalues >=0.2 && <0.3 + , Yampa >=0.10 && <0.11 + , gtk-helpers >=0.0 && <0.1 + , gtk >=0.14 && <0.15 + , keera-hails-reactive-gtk >=0.3 && <0.4 + , keera-hails-reactive-yampa >=0.0 && <0.1 + , containers >=0.5 && <0.6 + , jack >=0.7 && <0.8 + , midi >=0.2 && <0.3 + , explicit-exception >=0.1 && <0.2 + , transformers >=0.4 && <0.6 + , event-list >=0.1 && <0.2 + , keera-callbacks >=0.1 && <0.2 + , glib >=0.13 && <0.14 + , directory >=1.2 && <1.3 + , process >=1.4 && <1.5 hs-source-dirs: src build-tools: hsc2hs default-language: Haskell2010 -- 2.44.1 From 1364e9e7926041ba827b93f9e96de58a9693d577 Mon Sep 17 00:00:00 2001 From: Guerric Chupin Date: Wed, 6 Jul 2016 14:52:38 +0100 Subject: [PATCH 12/16] Removed most warnings and solved non-rotating tile problem. --- .gitignore | 3 +- RMCA.cabal | 2 +- src/RMCA/Auxiliary/Auxiliary.hs | 16 ++---- src/RMCA/Auxiliary/RV.hs | 9 +++ src/RMCA/GUI/Board.hs | 14 ++--- src/RMCA/GUI/Buttons.hs | 1 - src/RMCA/GUI/Settings.hs | 91 ++++++++++++++++++++++-------- src/RMCA/Layer/Board.hs | 10 ---- src/RMCA/Layer/Layer.hs | 2 - src/RMCA/Main.hs | 15 ----- src/RMCA/Semantics.hs | 3 +- src/RMCA/Translator/Filter.hs | 8 +-- src/RMCA/Translator/Jack.hs | 6 +- src/RMCA/Translator/Message.hs | 2 +- src/RMCA/Translator/Note.hs | 8 +-- src/RMCA/Translator/RV.hs | 11 +--- src/RMCA/Translator/SortMessage.hs | 1 - src/RMCA/Translator/Translator.hs | 1 - 18 files changed, 97 insertions(+), 106 deletions(-) diff --git a/.gitignore b/.gitignore index e4389de..4f25fbf 100644 --- a/.gitignore +++ b/.gitignore @@ -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 diff --git a/RMCA.cabal b/RMCA.cabal index 9f16a73..9d28c67 100644 --- a/RMCA.cabal +++ b/RMCA.cabal @@ -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 diff --git a/src/RMCA/Auxiliary/Auxiliary.hs b/src/RMCA/Auxiliary/Auxiliary.hs index 4c9a4a5..328ee64 100644 --- a/src/RMCA/Auxiliary/Auxiliary.hs +++ b/src/RMCA/Auxiliary/Auxiliary.hs @@ -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 _ = () diff --git a/src/RMCA/Auxiliary/RV.hs b/src/RMCA/Auxiliary/RV.hs index c5acdab..d1624d7 100644 --- a/src/RMCA/Auxiliary/RV.hs +++ b/src/RMCA/Auxiliary/RV.hs @@ -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 diff --git a/src/RMCA/GUI/Board.hs b/src/RMCA/GUI/Board.hs index eb51fcf..23a12b8 100644 --- a/src/RMCA/GUI/Board.hs +++ b/src/RMCA/GUI/Board.hs @@ -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 diff --git a/src/RMCA/GUI/Buttons.hs b/src/RMCA/GUI/Buttons.hs index d4ebc27..651959a 100644 --- a/src/RMCA/GUI/Buttons.hs +++ b/src/RMCA/GUI/Buttons.hs @@ -1,7 +1,6 @@ -- Contains button name definition module RMCA.GUI.Buttons where -import Graphics.UI.Gtk import System.Glib gtkMediaPlay :: DefaultGlibString diff --git a/src/RMCA/GUI/Settings.hs b/src/RMCA/GUI/Settings.hs index bbde293..9604363 100644 --- a/src/RMCA/GUI/Settings.hs +++ b/src/RMCA/GUI/Settings.hs @@ -1,4 +1,4 @@ -{-# 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 diff --git a/src/RMCA/Layer/Board.hs b/src/RMCA/Layer/Board.hs index 7cc8c26..12ebb1f 100644 --- a/src/RMCA/Layer/Board.hs +++ b/src/RMCA/Layer/Board.hs @@ -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) diff --git a/src/RMCA/Layer/Layer.hs b/src/RMCA/Layer/Layer.hs index 5e8571b..f0f5c70 100644 --- a/src/RMCA/Layer/Layer.hs +++ b/src/RMCA/Layer/Layer.hs @@ -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 diff --git a/src/RMCA/Main.hs b/src/RMCA/Main.hs index 623ac85..96eed05 100644 --- a/src/RMCA/Main.hs +++ b/src/RMCA/Main.hs @@ -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 diff --git a/src/RMCA/Semantics.hs b/src/RMCA/Semantics.hs index 4deb830..43d27eb 100644 --- a/src/RMCA/Semantics.hs +++ b/src/RMCA/Semantics.hs @@ -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 diff --git a/src/RMCA/Translator/Filter.hs b/src/RMCA/Translator/Filter.hs index 9afcb93..390f000 100644 --- a/src/RMCA/Translator/Filter.hs +++ b/src/RMCA/Translator/Filter.hs @@ -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 _ = [] diff --git a/src/RMCA/Translator/Jack.hs b/src/RMCA/Translator/Jack.hs index d85f492..a8a4138 100644 --- a/src/RMCA/Translator/Jack.hs +++ b/src/RMCA/Translator/Jack.hs @@ -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. diff --git a/src/RMCA/Translator/Message.hs b/src/RMCA/Translator/Message.hs index 8663e69..3462fbe 100644 --- a/src/RMCA/Translator/Message.hs +++ b/src/RMCA/Translator/Message.hs @@ -1,7 +1,6 @@ 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 diff --git a/src/RMCA/Translator/Note.hs b/src/RMCA/Translator/Note.hs index 3b640e5..2d0530f 100644 --- a/src/RMCA/Translator/Note.hs +++ b/src/RMCA/Translator/Note.hs @@ -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 diff --git a/src/RMCA/Translator/RV.hs b/src/RMCA/Translator/RV.hs index f2ba9f4..f50e6b8 100644 --- a/src/RMCA/Translator/RV.hs +++ b/src/RMCA/Translator/RV.hs @@ -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 diff --git a/src/RMCA/Translator/SortMessage.hs b/src/RMCA/Translator/SortMessage.hs index b2135a0..57f1c8d 100644 --- a/src/RMCA/Translator/SortMessage.hs +++ b/src/RMCA/Translator/SortMessage.hs @@ -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 diff --git a/src/RMCA/Translator/Translator.hs b/src/RMCA/Translator/Translator.hs index 62c2729..6358025 100644 --- a/src/RMCA/Translator/Translator.hs +++ b/src/RMCA/Translator/Translator.hs @@ -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 -- 2.44.1 From 0c2a2ea9ea7ee4d5d705df2d5ece1de68837ac67 Mon Sep 17 00:00:00 2001 From: Guerric Chupin Date: Wed, 6 Jul 2016 15:11:58 +0100 Subject: [PATCH 13/16] Removed most warnings. --- src/RMCA/Auxiliary/Auxiliary.hs | 1 + src/RMCA/Auxiliary/RV.hs | 9 +++------ src/RMCA/GUI/Board.hs | 19 ++++++++++--------- src/RMCA/Global/Clock.hs | 2 +- src/RMCA/Semantics.hs | 13 ++++++++----- src/RMCA/Translator/Note.hs | 4 +++- 6 files changed, 26 insertions(+), 22 deletions(-) diff --git a/src/RMCA/Auxiliary/Auxiliary.hs b/src/RMCA/Auxiliary/Auxiliary.hs index 328ee64..60750d3 100644 --- a/src/RMCA/Auxiliary/Auxiliary.hs +++ b/src/RMCA/Auxiliary/Auxiliary.hs @@ -34,6 +34,7 @@ onChange' = proc x -> do x' <- stepBack -< x returnA -< makeEvent x x' +makeEvent :: (Eq a) => a -> Maybe a -> Event a makeEvent x x' | isNothing x' = Event x | otherwise = let x'' = fromJust x' in diff --git a/src/RMCA/Auxiliary/RV.hs b/src/RMCA/Auxiliary/RV.hs index d1624d7..b97cabe 100644 --- a/src/RMCA/Auxiliary/RV.hs +++ b/src/RMCA/Auxiliary/RV.hs @@ -100,8 +100,7 @@ liftW3 f a b c = ReactiveFieldWrite setter reactiveValueWrite b x2 reactiveValueWrite c x3 -liftRW3 :: ( Monad m - , ReactiveValueReadWrite a b m +liftRW3 :: ( ReactiveValueReadWrite a b m , ReactiveValueReadWrite c d m , ReactiveValueReadWrite e f m) => BijectiveFunc i (b,d,f) @@ -115,8 +114,7 @@ liftRW3 bij a b c = ReactiveFieldWrite setter = liftW3 f1 a b c (f1, f2) = (direct bij, inverse bij) -liftR4 :: ( Monad m - , ReactiveValueRead a b m +liftR4 :: ( ReactiveValueRead a b m , ReactiveValueRead c d m , ReactiveValueRead e f m , ReactiveValueRead g h m) => @@ -158,8 +156,7 @@ liftW4 f a b c d = ReactiveFieldWrite setter reactiveValueWrite c x3 reactiveValueWrite d x4 -liftRW4 :: ( Monad m - , ReactiveValueReadWrite a b m +liftRW4 :: ( ReactiveValueReadWrite a b m , ReactiveValueReadWrite c d m , ReactiveValueReadWrite e f m , ReactiveValueReadWrite g h m) => diff --git a/src/RMCA/GUI/Board.hs b/src/RMCA/GUI/Board.hs index 23a12b8..b5f401d 100644 --- a/src/RMCA/GUI/Board.hs +++ b/src/RMCA/GUI/Board.hs @@ -26,6 +26,7 @@ data GUICell = GUICell { cellAction :: Action , asPh :: Bool } deriving(Show) +rotateGUICell :: GUICell -> GUICell rotateGUICell g = g { cellAction = rotateAction $ cellAction g } where rotateAction (ChDir b na d) = ChDir b na (nextDir d) rotateAction x = x @@ -51,13 +52,19 @@ tileW :: Int tileW = 40 tileH :: Int -tileH = round (sqrt 3 * fromIntegral tileW / 3) +tileH = round d + where d :: Double + d = sqrt 3 * fromIntegral tileW / 3 hexW :: Int -hexW = round (4 * fromIntegral tileW / 3) +hexW = round d + where d :: Double + d = 4 * fromIntegral tileW / 3 hexH :: Int -hexH = round (sqrt 3 * fromIntegral hexW / 2) +hexH = round d + where d :: Double + d = sqrt 3 * fromIntegral hexW / 2 xMax, yMax :: Int (xMax,yMax) = BF.second (*2) $ neighbor N nec @@ -108,12 +115,6 @@ validArea = filter (onBoard . fromGUICoords) $ outGUIBoard :: (Int,Int) -> Bool outGUIBoard (xf,yf) = xf < xMin || xf > xMax || yf < yMin || yf > yMax -na = NoteAttr { - naArt = Accent13, - naDur = 1 % 1, - naOrn = Ornaments Nothing [] NoSlide - } - inertCell :: GUICell inertCell = GUICell { cellAction = Inert , repeatCount = 1 diff --git a/src/RMCA/Global/Clock.hs b/src/RMCA/Global/Clock.hs index a664cc9..31bbfc0 100644 --- a/src/RMCA/Global/Clock.hs +++ b/src/RMCA/Global/Clock.hs @@ -37,7 +37,7 @@ mkClockGeneric io d = do modifyCBMVar n return io return (n, tid) - where dInt = floor $ d * (10^3) + where dInt = floor $ d * 1000 -- Ticking clock in the IO monad, sending callbacks every t milliseconds. mkClock :: DTime -> IO TickingClock diff --git a/src/RMCA/Semantics.hs b/src/RMCA/Semantics.hs index 43d27eb..4e91654 100644 --- a/src/RMCA/Semantics.hs +++ b/src/RMCA/Semantics.hs @@ -118,7 +118,9 @@ type MIDINN = Int -- Assume MIDI convetion: 60 = "Middle C" = C4 +middleC :: Int middleC = 60 +middleCOct :: MIDINN middleCOct = 4 @@ -187,6 +189,7 @@ data Articulation = NoAccent | Accent24 deriving (Eq, Show, Enum) +accentStrength :: Strength accentStrength = 1.2 -- Articulated strength @@ -564,12 +567,12 @@ runRMCA bd bpb mri tr st ppNotes :: BeatsPerBar -> [[Note]] -> IO () ppNotes bpb nss = ppnAux (zip [(br,bn) | br <- [1..], bn <- [1..bpb]] nss) - where - ppnAux [] = return () - ppnAux ((_, []) : tnss) = ppnAux tnss - ppnAux ((t, ns) : tnss) = do + where ppnAux :: [((Int,BeatsPerBar),[Note])] -> IO () + ppnAux [] = return () + ppnAux ((_, []) : tnss) = ppnAux tnss + ppnAux ((t, ns) : tnss) = do putStrLn (leftJustify 10 (show t) ++ ": " - ++ intercalate ", " (map show ns)) + ++ intercalate ", " (map show ns)) ppnAux tnss diff --git a/src/RMCA/Translator/Note.hs b/src/RMCA/Translator/Note.hs index 2d0530f..f3865c3 100644 --- a/src/RMCA/Translator/Note.hs +++ b/src/RMCA/Translator/Note.hs @@ -27,7 +27,9 @@ noteToMessages :: LTempo noteToMessages layTempo sr chan = proc (t,n@Note { noteDur = d }) -> do nm <- noteOnToMessage chan -< n - let dt = fromRational (d * toRational (tempoToQNoteIvl layTempo)) + let dt :: Double + dt = fromRational (d * toRational (tempoToQNoteIvl layTempo)) + dn :: Int dn = floor $ dt * fromIntegral sr returnA -< [(t,nm),(t + dn,switchOnOff nm)] -- 2.44.1 From d46b086cd0c58b901e7d6d4e11253ba4860a089a Mon Sep 17 00:00:00 2001 From: Guerric Chupin Date: Wed, 6 Jul 2016 15:17:07 +0100 Subject: [PATCH 14/16] Deleted 'Unknown' directory. --- src/RMCA/Unknown/Arpeggiated.hs | 22 ------ src/RMCA/Unknown/Auxiliary.hs | 14 ---- src/RMCA/Unknown/AvgInt.hs | 36 --------- src/RMCA/Unknown/AvgIvl.hs | 41 ---------- src/RMCA/Unknown/ClientState.hs | 10 --- src/RMCA/Unknown/MIDI.hs | 103 ------------------------- src/RMCA/Unknown/Reactimation.hs | 57 -------------- src/RMCA/Unknown/Reactogon.hs | 128 ------------------------------- src/RMCA/Unknown/Shared.hs | 30 -------- src/RMCA/Unknown/Time.hs | 14 ---- 10 files changed, 455 deletions(-) delete mode 100644 src/RMCA/Unknown/Arpeggiated.hs delete mode 100644 src/RMCA/Unknown/Auxiliary.hs delete mode 100644 src/RMCA/Unknown/AvgInt.hs delete mode 100644 src/RMCA/Unknown/AvgIvl.hs delete mode 100644 src/RMCA/Unknown/ClientState.hs delete mode 100644 src/RMCA/Unknown/MIDI.hs delete mode 100644 src/RMCA/Unknown/Reactimation.hs delete mode 100644 src/RMCA/Unknown/Reactogon.hs delete mode 100644 src/RMCA/Unknown/Shared.hs delete mode 100644 src/RMCA/Unknown/Time.hs diff --git a/src/RMCA/Unknown/Arpeggiated.hs b/src/RMCA/Unknown/Arpeggiated.hs deleted file mode 100644 index 8ecf1be..0000000 --- a/src/RMCA/Unknown/Arpeggiated.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE Arrows #-} - -module Arpeggiated where - -import FRP.Yampa - -import MIDI -import Note - -arpeggiated :: SF (ControllerValue, Event Note) (Event Note) -arpeggiated = proc (c,n) -> do - non <- uncurry gate ^<< identity &&& arr (event False isOn) -< n - non' <- fmap majorThird ^<< delayEvent t -< non - non'' <- fmap perfectFifth ^<< delayEvent t -< non' - (nof', - nof'') <- makeOff *** makeOff -< (non',non'') - -- It's assumed that the NoteOff event corresponding to n will be - -- emitted. - returnA -< mergeEvents [n, non, non', nof', non'', nof''] - where onoffGap = 0.9*t - t = 100000 - makeOff = delayEvent onoffGap <<^ fmap switchOnOff diff --git a/src/RMCA/Unknown/Auxiliary.hs b/src/RMCA/Unknown/Auxiliary.hs deleted file mode 100644 index c440774..0000000 --- a/src/RMCA/Unknown/Auxiliary.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Auxiliary ( breakMap - )where - -import Control.Arrow -import Data.Map (Map) -import qualified Data.Map as M - -dupl :: (Arrow a) => a b c -> a (b,b) (c,c) -dupl f = f *** f - -breakMap :: (Ord k) => k -> Map k a -> (Map k a, Map k a) -breakMap k m = (smaller, larger') - where (smaller, maybeValue, larger) = M.splitLookup k m - larger' = maybe larger (\v -> M.insert k v larger) maybeValue diff --git a/src/RMCA/Unknown/AvgInt.hs b/src/RMCA/Unknown/AvgInt.hs deleted file mode 100644 index 6456b03..0000000 --- a/src/RMCA/Unknown/AvgInt.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE Arrows #-} - -module AvgInt ( avgInt - ) where - -import FRP.Yampa - -intNum :: Int -intNum = 3 - -maxTime :: DTime -maxTime = 10 - -infinity :: (Fractional a) => a -infinity = 1/0 - --- Outputs the average time between intNum of the last events. Goes to --- infinity if less than intNum events have occured or if no event has --- occured in maxTime. -avgInt :: SF (Event a) DTime -avgInt = avgInt' [] `switch` ((>>^ fst) . avgInt') - where avgInt' :: [DTime] -> SF (Event a) (DTime, Event [DTime]) - avgInt' l = proc e -> do - t <- localTime -< () - tooLate <- after maxTime [] -< () - let timeList = (e `tag` (appDTime intNum t l)) `lMerge` tooLate - returnA -< (avgS intNum l, timeList) - -appDTime :: Int -> Time -> [DTime] -> [DTime] -appDTime _ _ [] = [0] -appDTime n t l = (t - head l):(take (n-1) l) - -avgS :: (Fractional a) => Int -> [a] -> a -avgS n l - | length l /= n = infinity - | otherwise = foldl (+) 0 l / fromIntegral n diff --git a/src/RMCA/Unknown/AvgIvl.hs b/src/RMCA/Unknown/AvgIvl.hs deleted file mode 100644 index 4a88407..0000000 --- a/src/RMCA/Unknown/AvgIvl.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE Arrows #-} - -module AvgIvl ( avgIvl - ) where - -import FRP.Yampa - -import Debug.Trace - -ivlNum :: Int -ivlNum = 3 - -maxTime :: DTime -maxTime = 5 - -infinity :: (Fractional a) => a -infinity = 1/0 - --- Outputs the average time between ivlNum of the last events. Goes to --- infinity if less than ivlNum events have occured or if no event has --- occured in maxTime. -avgIvl :: SF (Event a) DTime -avgIvl = switch (constant infinity &&& constant (Event [])) avgIvl' - where - avgIvl' l = switch avgIvl'' (avgIvl') - where avgIvl'' :: SF (Event a) (DTime, Event [DTime]) - avgIvl'' = proc e -> do - e' <- notYet -< e - t <- localTime -< () - tooLate <- after maxTime [] -< () - let timeList = (e' `tag` (appDTime ivlNum t l)) `lMerge` tooLate - returnA -< (avgS ivlNum l, timeList) - -appDTime :: Int -> Time -> [DTime] -> [DTime] -appDTime _ _ [] = [0] -appDTime n t l = t:(take (n-1) l) - -avgS :: (Fractional a) => Int -> [a] -> a -avgS n l - | length l /= n = infinity - | otherwise = foldl (+) 0 l / fromIntegral n diff --git a/src/RMCA/Unknown/ClientState.hs b/src/RMCA/Unknown/ClientState.hs deleted file mode 100644 index f1b1e0c..0000000 --- a/src/RMCA/Unknown/ClientState.hs +++ /dev/null @@ -1,10 +0,0 @@ -module ClientState where - -import Sound.JACK ( NFrames - ) -import FRP.Yampa - -data ClientState = ClientState { rate :: Int - , buffSize :: NFrames - , clientClock :: Time - } diff --git a/src/RMCA/Unknown/MIDI.hs b/src/RMCA/Unknown/MIDI.hs deleted file mode 100644 index e6316da..0000000 --- a/src/RMCA/Unknown/MIDI.hs +++ /dev/null @@ -1,103 +0,0 @@ -module MIDI ( EventQueue - , SampleRate - , Pitch - , toPitch - , fromPitch - , fromVelocity - , toVelocity - , Velocity - , Message ( NoteOn - , NoteOff - , Control - ) - , fromRawMessage - , toRawMessage - , ControllerIdx - , ControllerValue - ) where - -import qualified Sound.MIDI.Message as Message - -import Sound.MIDI.Message.Channel.Voice ( fromPitch - , toPitch - , fromVelocity - , toVelocity - ) -import qualified Sound.MIDI.Message.Channel as Channel -import qualified Sound.MIDI.Message.Channel.Voice as Voice -import Data.Map (Map) -import FRP.Yampa - -type EventQueue = Map Time Message - -type SampleRate = Int - -type RawMessage = Message.T - -{- -class Message a where - fromMessage :: RawMessage -> Maybe a - toMessage :: a -> RawMessage --} - -type MidiVoice = Voice.T - -type Channel = Channel.Channel -type Pitch = Voice.Pitch -type Velocity = Voice.Velocity - -type ControllerIdx = Voice.Controller -type ControllerValue = Int - -data Message = NoteOn Channel Pitch Velocity - | NoteOff Channel Pitch Velocity - | Control Channel ControllerIdx ControllerValue - deriving(Show) - -fromRawMessage :: RawMessage -> Maybe Message -fromRawMessage (Message.Channel (Channel.Cons c - (Channel.Voice (Voice.NoteOn p v)))) = Just $ NoteOn c p v -fromRawMessage (Message.Channel (Channel.Cons c - (Channel.Voice (Voice.NoteOff p v)))) = Just $ NoteOff c p v -fromRawMessage (Message.Channel (Channel.Cons c - (Channel.Voice (Voice.Control n v)))) = Just $ Control c n v -fromRawMessage _ = Nothing - -toRawMessage :: Message -> RawMessage -toRawMessage (NoteOn c p v) = (Message.Channel $ Channel.Cons c - (Channel.Voice $ Voice.NoteOn p v)) -toRawMessage (NoteOff c p v) = (Message.Channel $ Channel.Cons c - (Channel.Voice $ Voice.NoteOff p v)) -toRawMessage (Control c n v) = (Message.Channel (Channel.Cons c - (Channel.Voice (Voice.Control n v)))) - -{- -instance Message Note where - fromMessage (Message.Channel (Channel.Cons c - (Channel.Voice (Voice.NoteOn p v)))) = Just $ NoteOn c p v - fromMessage (Message.Channel (Channel.Cons c - (Channel.Voice (Voice.NoteOff p v)))) = Just $ NoteOff c p v - fromMessage _ = Nothing - toMessage (NoteOn c p v) = (Message.Channel $ Channel.Cons c - (Channel.Voice $ Voice.NoteOn p v)) - toMessage (NoteOff c p v) = (Message.Channel $ Channel.Cons c - (Channel.Voice $ Voice.NoteOff p v)) -{- -instance Voice Note where - fromVoice (Voice.NoteOn p v) = Just $ NoteOn p v - fromVoice (Voice.NoteOff p v) = Just $ NoteOff p v - fromVoice _ = Nothing - toVoice (NoteOn p v) = Voice.NoteOn p v - toVoice (NoteOff p v) = Voice.NoteOff p v --} --} -{- - -data Control = Control ControllerIdx ControllerValue --} -{- -instance Voice Control where - fromVoice (Voice.Control i v) = Just $ Control i v - fromVoice _ = Nothing - toVoice (Control i v) = Voice.Control i v --} diff --git a/src/RMCA/Unknown/Reactimation.hs b/src/RMCA/Unknown/Reactimation.hs deleted file mode 100644 index e8f244f..0000000 --- a/src/RMCA/Unknown/Reactimation.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# LANGUAGE Arrows #-} - -module Reactimation where - -import Data.Map ( Map - , empty - ) -import qualified Data.Map as M -import FRP.Yampa -import Control.Concurrent.MVar -import Sound.JACK ( NFrames(NFrames) - ) - -import MIDI -import ClientState ---import Arpeggiated - -mainReact :: MVar EventQueue - -> MVar EventQueue - -> MVar ClientState - -> IO () -mainReact inRef outRef clientRef = - reactimate (initialize inRef) (sensing clientRef inRef) (actuation outRef) $ - proc _ -> do - returnA -< M.empty - - {-mainSF-} - -initialize :: MVar EventQueue -> IO EventQueue -initialize inRef = takeMVar inRef - -sensing :: MVar ClientState - -> MVar EventQueue - -> Bool - -> IO (DTime, Maybe EventQueue) -sensing clientRef inRef _ = do - print "Reading." - client <- readMVar clientRef - input <- takeMVar inRef - let (NFrames buff) = buffSize client - dt = (fromIntegral $ rate client)/(fromIntegral buff) - print "Done reading." - return (dt, Just input) - -actuation :: MVar EventQueue - -> Bool - -> EventQueue - -> IO Bool -actuation outRef _ output = do - print "Actuating." - out <- takeMVar outRef - putMVar outRef $ M.union output out - print "Done actuating." - return True - -mainSF :: SF EventQueue EventQueue -mainSF = identity diff --git a/src/RMCA/Unknown/Reactogon.hs b/src/RMCA/Unknown/Reactogon.hs deleted file mode 100644 index 83b455a..0000000 --- a/src/RMCA/Unknown/Reactogon.hs +++ /dev/null @@ -1,128 +0,0 @@ -module Main where - -import Auxiliary -import MIDI -import ClientState -import Reactimation - -import qualified Sound.JACK as Jack -import qualified Sound.JACK.MIDI as JMIDI -import qualified Sound.MIDI.Message as MIDI -import qualified Sound.MIDI.Message.Channel as Channel -import qualified Sound.MIDI.Message.Channel.Voice as Voice -import qualified Sound.MIDI.Message.Class.Construct as MidiCons - -import Control.Concurrent -import Control.Monad -import qualified Control.Monad.Exception.Synchronous as Sync -import qualified Control.Monad.Trans.Class as Trans -import qualified Data.EventList.Absolute.TimeBody as EventListAbs -import qualified Data.EventList.Relative.TimeBody as EventList -import qualified Data.EventList.Relative.TimeMixed as EventListTM -import qualified Foreign.C.Error as E - -import qualified Data.Map as M -import FRP.Yampa - -import Debug.Trace -{- --- | List of absolute times (at which events should occur) and events. --- We assume that the list is sorted. -outLoop :: [(Time,MIDI.T)] -outLoop = concat [[(t,MIDI.Channel $ Channel.Cons - { Channel.messageChannel = Channel.toChannel 4 - , Channel.messageBody = - Channel.Voice $ Voice.NoteOn (Voice.toPitch 60) (Voice.toVelocity 100) - }),(t+0.5,MIDI.Channel $ Channel.Cons - { Channel.messageChannel = Channel.toChannel 4 - , Channel.messageBody = - Channel.Voice $ Voice.NoteOff (Voice.toPitch 60) (Voice.toVelocity 100) - })] | t <- [0,2..]] --} - -rmcaName :: String -rmcaName = "RMCA" - -inPortName :: String -inPortName = "input" - -outPortName :: String -outPortName = "output" - -fsPortName :: String -fsPortName = "fluidsynth:midi" - -main = do - inState <- newMVar M.empty - outState <- newMVar M.empty - Jack.handleExceptions $ - Jack.withClientDefault rmcaName $ \client -> - Jack.withPort client outPortName $ \output -> - Jack.withPort client inPortName $ \input -> do - clientState <- Trans.lift $ newEmptyMVar - Jack.withProcess client - (jackLoop client clientState inState outState input output) $ - Jack.withActivation client $ do - frpid <- Trans.lift $ forkIO $ mainReact inState outState clientState - Jack.connect client (rmcaName ++ ":" ++ outPortName) fsPortName - Trans.lift $ putStrLn $ "Started " ++ rmcaName - Trans.lift $ Jack.waitForBreak - -jackLoop :: Jack.Client - -> MVar ClientState -- ^ MVar containing the client state (rate and buff size) - -> MVar EventQueue -- ^ MVar containing incoming events - -> MVar EventQueue -- ^ MVar containing exiting events - -> JMIDI.Port Jack.Input -- ^ Jack input port - -> JMIDI.Port Jack.Output -- ^ Jack output port - -> Jack.NFrames -- ^ Buffer size for the ports - -> Sync.ExceptionalT E.Errno IO () -jackLoop client clientState inRef outRef - input output nframes@(Jack.NFrames nframesInt) = do - Trans.lift $ print "Entering Jack." - rate <- Trans.lift $ Jack.getSampleRate client - lframe <- Trans.lift $ Jack.lastFrameTime client - isEmptyState <- Trans.lift $ isEmptyMVar clientState - let updateClient = if isEmptyState - then putMVar - else \c v -> void $ swapMVar c v - rateD = fromIntegral rate - (Jack.NFrames lframeInt) = lframe - currentTime = fromIntegral lframeInt / rateD - Trans.lift $ updateClient clientState $ ClientState { rate = rate - , buffSize = nframes - , clientClock = currentTime - } - outEvents <- Trans.lift $ takeMVar outRef - inEventsT <- JMIDI.readEventsFromPort input nframes - let inEvents :: EventQueue - inEvents = M.mapMaybe fromRawMessage $ - M.fromList $ - map (\(Jack.NFrames n,e) -> (currentTime + fromIntegral n/rateD, e)) $ - EventListAbs.toPairList inEventsT - Trans.lift $ print "In the middle." - Trans.lift $ putMVar inRef inEvents - Trans.lift $ print "In the middle." - let playableEvents = M.filterWithKey - (\t _ -> t - currentTime > - fromIntegral nframesInt / rateD) $ - M.union inEvents outEvents - (processableEvents, futureEvents) = breakMap currentTime playableEvents - processableEvents' = M.toList processableEvents - Trans.lift $ print currentTime - Trans.lift $ putMVar outRef futureEvents - let smartSub x y = if x < y then y - x else x - y - (firstTime,_) = head processableEvents' - Trans.lift $ print $ - map ((* rateD) . smartSub firstTime . fst) processableEvents' - JMIDI.writeEventsToPort output nframes $ - EventListAbs.fromPairList $ - map (\(t,e) -> (Jack.NFrames $ floor $ rateD * smartSub t currentTime - , toRawMessage e)) $ - M.toList processableEvents - Trans.lift $ print "Exiting Jack." -{- - else JMIDI.writeEventsToPort output nframes $ - EventListAbs.mapTime Jack.NFrames $ - EventList.toAbsoluteEventList 0 $ - EventList.mapTime (\(Jack.NFrames n) -> n) $ - EventList.fromPairList processableEvents --} diff --git a/src/RMCA/Unknown/Shared.hs b/src/RMCA/Unknown/Shared.hs deleted file mode 100644 index b2f5309..0000000 --- a/src/RMCA/Unknown/Shared.hs +++ /dev/null @@ -1,30 +0,0 @@ -module Shared ( inRef - , outRef - , clientRef - ) where - -import ClientState -import MIDI - -import Control.Concurrent.MVar -import Data.Map ( Map - , empty - ) -import FRP.Yampa -import Sound.JACK ( NFrames - ) - --- | MVar containing all the events given by the input port. -inRef :: IO (MVar EventQueue) -inRef = newMVar empty - --- | MVar containing all the events to be given to the output port. -outRef :: IO (MVar EventQueue) -outRef = newMVar empty - --- | MVar containing the state of the machine (JACK client and ports). -clientRef :: Int -> NFrames -> NFrames -> IO (MVar ClientState) -clientRef rate outSize inSize = newMVar $ ClientState { rate = rate - , outSize = outSize - , inSize = inSize - } diff --git a/src/RMCA/Unknown/Time.hs b/src/RMCA/Unknown/Time.hs deleted file mode 100644 index 4b4fa31..0000000 --- a/src/RMCA/Unknown/Time.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Time ( toFrames - , fromFrames - ) where - -import FRP.Yampa -import Sound.JACK (NFrames(NFrames)) - -import MIDI - -toFrames :: SampleRate -> DTime -> NFrames -toFrames s = NFrames . floor . (fromIntegral s *) - -fromFrames :: SampleRate -> NFrames -> DTime -fromFrames s (NFrames n) = fromIntegral n/fromIntegral s -- 2.44.1 From e7a5c5bbb36e0d67b53107c27a0c1240b4939c81 Mon Sep 17 00:00:00 2001 From: Guerric Chupin Date: Wed, 6 Jul 2016 15:19:50 +0100 Subject: [PATCH 15/16] Removed useless dependencies in .cabal. --- RMCA.cabal | 2 -- 1 file changed, 2 deletions(-) diff --git a/RMCA.cabal b/RMCA.cabal index 9d28c67..c6d1803 100644 --- a/RMCA.cabal +++ b/RMCA.cabal @@ -44,8 +44,6 @@ executable RMCA , event-list >=0.1 && <0.2 , keera-callbacks >=0.1 && <0.2 , glib >=0.13 && <0.14 - , directory >=1.2 && <1.3 - , process >=1.4 && <1.5 hs-source-dirs: src build-tools: hsc2hs default-language: Haskell2010 -- 2.44.1 From 785107ebc1c5620b5081e09ef4eb4f6bf8146b2b Mon Sep 17 00:00:00 2001 From: Guerric Chupin Date: Wed, 6 Jul 2016 16:19:58 +0100 Subject: [PATCH 16/16] Revert Auxiliary.hs --- src/RMCA/Auxiliary/Auxiliary.hs | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/src/RMCA/Auxiliary/Auxiliary.hs b/src/RMCA/Auxiliary/Auxiliary.hs index 60750d3..4c9a4a5 100644 --- a/src/RMCA/Auxiliary/Auxiliary.hs +++ b/src/RMCA/Auxiliary/Auxiliary.hs @@ -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,_) x' = (Just x', Nothing) + f (Nothing,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,6 +25,10 @@ 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 @@ -32,14 +36,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 :: (Eq a) => a -> Maybe a -> Event a -makeEvent x x' - | isNothing x' = Event x - | otherwise = let x'' = fromJust x' in - if x'' == x then NoEvent else Event x - discard :: a -> () discard _ = () -- 2.44.1