module Music.Theory.Z.SRO where
import Data.List
import qualified Text.ParserCombinators.Parsec as P
import qualified Music.Theory.List as T
import qualified Music.Theory.Parse as T
import Music.Theory.Z
data SRO t = SRO {sro_r :: Int
,sro_R :: Bool
,sro_T :: t
,sro_M :: Bool
,sro_I :: Bool}
deriving (Eq,Show)
sro_pp :: Show t => SRO t -> String
sro_pp (SRO rN r tN m i) =
concat [if rN /= 0 then 'r' : show rN else ""
,if r then "R" else ""
,'T' : show tN
,if m then "M" else ""
,if i then "I" else ""]
p_sro :: Integral t => P.GenParser Char () (SRO t)
p_sro = do
let rot = P.option 0 (P.char 'r' >> T.parse_int)
r <- rot
r' <- T.is_char 'R'
_ <- P.char 'T'
t <- T.parse_int
m <- T.is_char 'M'
i <- T.is_char 'I'
P.eof
return (SRO r r' t m i)
sro_parse :: Integral i => String -> SRO i
sro_parse =
either (\e -> error ("sro_parse failed\n" ++ show e)) id .
P.parse p_sro ""
z_sro_univ :: Integral i => Int -> Z i -> [SRO i]
z_sro_univ n_rot z =
[SRO r r' t m i |
r <- [0 .. n_rot 1],
r' <- [False,True],
t <- z_univ z,
m <- [False,True],
i <- [False,True]]
z_sro_Tn :: Integral i => Z i -> [SRO i]
z_sro_Tn z = [SRO 0 False n False False | n <- z_univ z]
z_sro_TnI :: Integral i => Z i -> [SRO i]
z_sro_TnI z =
[SRO 0 False n False i |
n <- z_univ z,
i <- [False,True]]
z_sro_RTnI :: Integral i => Z i -> [SRO i]
z_sro_RTnI z =
[SRO 0 r n False i |
r <- [True,False],
n <- z_univ z,
i <- [False,True]]
z_sro_TnMI :: Integral i => Z i -> [SRO i]
z_sro_TnMI z =
[SRO 0 False n m i |
n <- z_univ z,
m <- [True,False],
i <- [True,False]]
z_sro_RTnMI :: Integral i => Z i -> [SRO i]
z_sro_RTnMI z =
[SRO 0 r n m i |
r <- [True,False],
n <- z_univ z,
m <- [True,False],
i <- [True,False]]
z_sro_apply :: Integral i => i -> Z i -> SRO i -> [i] -> [i]
z_sro_apply mn z (SRO r r' t m i) x =
let x1 = if i then z_sro_invert z 0 x else x
x2 = if m then z_sro_mn z mn x1 else x1
x3 = z_sro_tn z t x2
x4 = if r' then reverse x3 else x3
in T.rotate_left r x4
z_sro_tn :: (Integral i, Functor f) => Z i -> i -> f i -> f i
z_sro_tn z n = fmap (z_add z n)
z_sro_invert :: (Integral i, Functor f) => Z i -> i -> f i -> f i
z_sro_invert z n = fmap (\p -> z_sub z n (z_sub z p n))
z_sro_tni :: (Integral i, Functor f) => Z i -> i -> f i -> f i
z_sro_tni z n = z_sro_tn z n . z_sro_invert z 0
z_sro_mn :: (Integral i, Functor f) => Z i -> i -> f i -> f i
z_sro_mn z n = fmap (z_mul z n)
z_sro_t_related :: (Integral i, Functor f) => Z i -> f i -> [f i]
z_sro_t_related z p = fmap (\n -> z_sro_tn z n p) (z_univ z)
z_sro_ti_related :: (Eq (f i), Integral i, Functor f) => Z i -> f i -> [f i]
z_sro_ti_related z p = nub (z_sro_t_related z p ++ z_sro_t_related z (z_sro_invert z 0 p))
z_sro_rti_related :: Integral i => Z i -> [i] -> [[i]]
z_sro_rti_related z p = let q = z_sro_ti_related z p in nub (q ++ map reverse q)
z_sro_tn_to :: Integral i => Z i -> i -> [i] -> [i]
z_sro_tn_to z n p =
case p of
[] -> []
x:xs -> n : z_sro_tn z (z_sub z n x) xs
z_sro_invert_ix :: Integral i => Z i -> Int -> [i] -> [i]
z_sro_invert_ix z n p = z_sro_invert z (p !! n) p
z_tmatrix :: Integral i => Z i -> [i] -> [[i]]
z_tmatrix z p = map (\n -> z_sro_tn z n p) (z_sro_tn_to z 0 (z_sro_invert_ix z 0 p))