-- want to remove that.
data Tile = TileW | TileB
-
rotateGUICell :: GUICell -> GUICell
rotateGUICell g = g { cellAction = rotateAction $ cellAction g }
where rotateAction (ChDir b na d) = ChDir b na (nextDir d)
+ rotateAction (Split na ds) = Split na (turnQueue ds 1)
rotateAction x = x
tileW :: Int
Stop _ -> "img/stop.svg"
ChDir True _ d -> "img/start" ++ show d ++ ".svg"
ChDir False _ d -> "img/ric" ++ show d ++ ".svg"
- Split _ -> "img/split.svg"
+ Split _ _ -> "img/split.svg"
})
| let actions = [ Absorb, Stop defNa
, ChDir False defNa N, ChDir True defNa N
- , Split defNa]
+ , Split defNa [0..5]]
-- /!\ It would be nice to find a general formula
-- for placing the control pieces.
, (y,action) <- zip [ yMin+4,yMin+8..] actions]
module RMCA.GUI.MultiBoard where
+import Debug.Trace
import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.IO.Class
module RMCA.GUI.NoteSettings where
+import Debug.Trace
import Control.Monad
import Data.List
import Data.Maybe
import RMCA.MCBMVar
import RMCA.Semantics
+toJust :: a -> Maybe a
+toJust a = Just a
+
+getSplit :: Action -> Maybe Action
+getSplit (Split na ds) = Just (Split na ds)
+getSplit _ = Nothing
+
+setSplitDir :: [Int] -> Action -> Action
+setSplitDir ds (Split na _) = Split na ds
+setSplitDir _ a = a
+
+getSplitDir :: Action -> Maybe [Int]
+getSplitDir (Split _ ds) = Just ds
+getSplitDir _ = Nothing
+
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
+setNAttr na (Split _ ds) = Split na ds
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
+getNAttr (Split na _) = Just na
symbolString :: [(Duration,String)]
symbolString = map (\(_,y,z) -> (z,y)) noteSymbList
naBox <- vBoxNew False 5
boxPackStart pieceBox naBox PackNatural 0
+
+
-- Articulation box
artCombo <- comboBoxNewText
artIndex <- mapM (\art -> do i <- comboBoxAppendText artCombo
boxPackStart noteDurBox noteDurCombo PackNatural 0
boxPackStart noteDurBox noteDurLabel PackNatural 0
+ -- Split direction box
+ splitDirBox <- hBoxNew False 10
+ splitDirCombo <- comboBoxNewText
+ splitDirIndex <- mapM (\(str, dir) -> do i <- comboBoxAppendText splitDirCombo
+ (fromString str)
+ return (dir, i)) dirList
+ comboBoxSetActive splitDirCombo 0
+ let indexToDir i =
+ fromMaybe (error "In indexToDir: failed \
+ \to find the correct \
+ \ direction for the \
+ \selected index.") $ lookup i $ map swap splitDirIndex
+ dirToIndex ds =
+ fromMaybe (error "In dirToIndex: \
+ \failed to find \
+ \the correct index \
+ \for the direction.") $ lookup ds' splitDirIndex where
+ ds' = fst $ fromProto ds
+
+ splitDirRV = bijection (indexToDir, dirToIndex) `liftRW`
+ comboBoxIndexRV splitDirCombo
+ splitDirLabel <- labelNew =<< return (Just "")
+ let splitDirLabelRV = labelTextReactive splitDirLabel
+ boxPackStart naBox splitDirBox PackNatural 0
+ boxPackStart splitDirBox splitDirCombo PackNatural 0
+ boxPackStart splitDirBox splitDirLabel PackNatural 0
+
-- Repeat count box
rCountAdj <- adjustmentNew 1 0 100 1 1 0
rCount <- spinButtonNew rCountAdj 1 0
-- Carries the index of the tile to display and what to display.
setRV <- newMCBMVar inertCell
+ reactiveValueOnCanRead splitDirRV $ do
+ cDir <- reactiveValueRead splitDirRV
+ oCell <- reactiveValueRead setRV
+ let nCa :: Action
+ nCa = cellAction oCell
+ nCell :: GUICell
+ nCell = if isJust $ getSplit nCa
+ then oCell { cellAction =
+ setSplitDir cDir nCa }
+ else oCell
+ reactiveValueWriteOnNotEq setRV nCell
+
+
reactiveValueOnCanRead noteDurRV $ do
nDur <- reactiveValueRead noteDurRV
oCell <- reactiveValueRead setRV
widgetHide artCombo
widgetShow rCount
widgetHideAll noteDurBox
+ widgetHideAll splitDirBox
showNa :: IO ()
showNa = do widgetShow slideCombo
widgetShow artCombo
widgetShow rCount
widgetShowAll noteDurBox
+ widgetHideAll splitDirBox
+ showDir :: IO ()
+ showDir = widgetShowAll splitDirBox
+
updateNaBox :: GUICell -> IO ()
updateNaBox GUICell { cellAction = act } = case act of
Inert -> hideNa
Absorb -> hideNa
+ Split _ _ -> showNa >> showDir
_ -> showNa
reactiveValueOnCanRead setRV $ postGUIAsync $ do
nCell <- reactiveValueRead setRV
+ fromMaybeM_ (fmap (reactiveValueWriteOnNotEq splitDirRV)
+ (getSplitDir $ cellAction nCell))
+ fromMaybeM_ (fmap (reactiveValueWriteOnNotEq splitDirLabelRV . show . snd . fromProto)
+ (getSplitDir $ cellAction nCell))
fromMaybeM_ (fmap (reactiveValueWriteOnNotEq artComboRV . naArt)
(getNAttr (cellAction nCell)))
- fromMaybeM_ (fmap (reactiveValueWriteOnNotEq slideComboRV
- . ornSlide . naOrn)
+ fromMaybeM_ (fmap (reactiveValueWriteOnNotEq slideComboRV . ornSlide . naOrn)
(getNAttr (cellAction nCell)))
reactiveValueWriteOnNotEq rCountRV $ repeatCount nCell
fromMaybeM_ (fmap (reactiveValueWriteOnNotEq noteDurRV . naDur)
module RMCA.Semantics where
+import Debug.Trace
import Data.Array
import Data.List (intercalate, nub)
-import Data.Maybe (catMaybes)
+import Data.Maybe (catMaybes, fromJust)
import RMCA.Auxiliary
turn :: Dir -> Angle -> Dir
turn d a = toEnum ((fromEnum d + a) `mod` 6)
-
type Pos = (Int, Int)
-- Position of neighbour in given direction
| Absorb -- Remove play head silently.
| 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.
+ | Split NoteAttr [Int] -- Play note then split head into more than one.
+ -- | Split NoteAttr -- Play note then split head into five.
deriving (Show,Read,Eq)
+dirList :: [(String, [Int])]
+dirList = [ ("0 1 2 3 4 5", [0, 1, 2, 3, 4, 5])
+ , ("0 1 2 3 4", [0, 1, 2, 3, 4])
+ , ("0 1 2 3", [0, 1, 2, 3])
+ , ("0 1 2 4", [0, 1, 2, 4])
+ , ("0 1 3 4", [0, 1, 3, 4])
+ , ("0 1 2", [0, 1, 2])
+ , ("0 1 3", [0, 1, 3])
+ , ("0 2 3", [0, 2, 3])
+ , ("0 2 4", [0, 2, 4])
+ , ("0 1", [0, 1])
+ , ("0 2", [0, 2])
+ , ("0 3", [0, 3])
+ ]
+
+turnQueue :: [Int] -> Int -> [Int]
+turnQueue ds n = sortQueue [] $ map ((`mod` 6) . (+ n)) ds
+
+sortQueue :: [Int] -> [Int] -> [Int]
+sortQueue [] ys = sortQueue [head ys] (tail ys)
+sortQueue xs [] = xs
+sortQueue xs ys = case last xs > head ys of
+ True -> ys ++ xs
+ False -> sortQueue (xs ++ [head ys]) (tail ys)
+
+fromProto :: [Int] -> ([Int], Int)
+fromProto ds = fromJust $ lookup s rotates where
+ s = minimum $ map fst rotates
+ rotates = [(sum ds', (ds', d)) | d <- ds, let ds' = turnQueue ds (-d)]
+
-- Contains a list of all the actions. Useful to have for e.g. pixbufs
-- generation. It is shared for all applications from here to avoid
-- forgetting to add a case if future actions are added.
actionList = [ Inert
, Absorb
, Stop noNoteAttr
- , Split noNoteAttr
] ++
+ [ Split noNoteAttr ds | proto <- map snd dirList
+ , offset <- [0..6]
+ , let ds = turnQueue proto offset
+ ] ++
[ ChDir t noNoteAttr d | t <- [True, False]
, d <- [minBound..maxBound]
]
anonymizeConstructor Inert = Inert
anonymizeConstructor Absorb = Absorb
anonymizeConstructor (Stop _) = Stop noNoteAttr
-anonymizeConstructor (Split _) = Split noNoteAttr
+anonymizeConstructor (Split _ ds) = Split noNoteAttr ds
anonymizeConstructor (ChDir t _ d) = ChDir t noNoteAttr d
-- Cells
Stop na -> (newPHs [], mkNote p bn tr st na)
ChDir _ na d' -> (newPHs [ph {phDir = d'}],
mkNote p bn tr st na)
- Split na -> (newPHs [ PlayHead {
+ Split na ds -> (newPHs [ PlayHead {
phPos = p,
phBTM = 0,
phDir = d'
}
- | a <- [-2 .. 2],
- let d' = turn d a
+ | a <- ds,
+ let d' = turn N a
],
mkNote p bn tr st na)
where
sourcephile / git / tmp / julm / arpeggigon.git / commitdiff