module Music.Theory.Pct where

import Data.Function
import Data.List
import Music.Theory.Prime
import Music.Theory.Pitch
import Music.Theory.Set
import Music.Theory.Table

-- | Basic interval pattern.
bip :: (Integral a) => [a] -> [a]
bip = sort . map ic . int

-- | Cardinality filter
cf :: (Integral n) => [n] -> [[a]] -> [[a]]
cf ns = filter (\p -> genericLength p `elem` ns)

cgg :: [[a]] -> [[a]]
cgg [] = [[]]
cgg (x:xs) = [ y:z | y <- x, z <- cgg xs ]

-- | Combinations generator (cg == poweset)
cg :: [a] -> [[a]]
cg = powerset

-- | Powerset filtered by cardinality.
cg_r :: (Integral n) => n -> [a] -> [[a]]
cg_r n = cf [n] . cg

-- | Cyclic interval segment.
ciseg :: (Integral a) => [a] -> [a]
ciseg = int . cyc

-- | pcset complement.
cmpl :: (Integral a) => [a] -> [a]
cmpl = ([0..11] \\) . pcset

-- | Form cycle.
cyc :: [a] -> [a]
cyc [] = []
cyc (x:xs) = (x:xs) ++ [x]

-- | Diatonic implications.
dim :: (Integral a) => [a] -> [(a, [a])]
dim p =
    let g (i,q) = is_subset p (tn i q)
        f = filter g . zip [0..11] . repeat
        d = [0,2,4,5,7,9,11]
        m = [0,2,3,5,7,9,11]
        o = [0,1,3,4,6,7,9,10]
    in f d ++ f m ++ f o

-- | Diatonic interval set to interval set.
dis :: (Integral t) => [Int] -> [t]
dis =
    let is = [[], [], [1,2], [3,4], [5,6], [6,7], [8,9], [10,11]]
    in concatMap (\j -> is !! j)

-- | Degree of intersection.
doi :: (Integral a) => Int -> [a] -> [a] -> [[a]]
doi n p q =
    let f j = [pcset (tn j p), pcset (tni j p)]
        xs = concatMap f [0..11]
    in set (filter (\x -> length (x `intersect` q) == n) xs)

-- | Forte name.
fn :: (Integral a) => [a] -> String
fn = sc_name

-- | p `has_ess` q is true iff p can embed q in sequence.
has_ess :: (Integral a) => [a] -> [a] -> Bool
has_ess _ [] = True
has_ess [] _ = False
has_ess (p:ps) (q:qs) = if p == q 
                        then has_ess ps qs 
                        else has_ess ps (q:qs)

-- | Embedded segment search.
ess :: (Integral a) => [a] -> [a] -> [[a]]
ess p = filter (`has_ess` p) . all_RTnMI

-- | Can the set-class q (under prime form algorithm pf) be 
--   drawn from the pcset p.
has_sc_pf :: (Integral a) => ([a] -> [a]) -> [a] -> [a] -> Bool
has_sc_pf pf p q =
    let n = length q
    in q `elem` map pf (cf [n] (powerset p))

-- | Can the set-class q be drawn from the pcset p.
has_sc :: (Integral a) => [a] -> [a] -> Bool
has_sc = has_sc_pf forte_prime

-- | Interval cycle filter.
icf :: (Num a) => [[a]] -> [[a]]
icf = filter ((== 12) . sum)

-- | Interval class set to interval sets.
ici :: (Num t) => [Int] -> [[t]]
ici xs =
    let is j = [[0], [1,11], [2,10], [3,9], [4,8], [5,7], [6]] !! j
        ys = map is xs
    in cgg ys

-- | Interval class set to interval sets, concise variant.
ici_c :: [Int] -> [[Int]]
ici_c [] = []
ici_c (x:xs) = map (x:) (ici xs)

-- | Interval-class segment.
icseg :: (Integral a) => [a] -> [a]
icseg = map ic . iseg

-- | Interval segment (INT).
iseg :: (Integral a) => [a] -> [a]
iseg = int

-- | Imbrications.
imb :: (Integral n) => [n] -> [a] -> [[a]]
imb cs p =
    let g n = (== n) . genericLength
        f ps n = filter (g n) (map (genericTake n) ps)
    in concatMap (f (tails p)) cs

-- | p `issb` q gives the set-classes that can append to p to give q.
issb :: (Integral a) => [a] -> [a] -> [String]
issb p q =
    let k = length q - length p
        f = any id . map (\x -> forte_prime (p ++ x) == q) . all_TnI
    in map sc_name (filter f (cf [k] scs))

-- | Matrix search.
mxs :: (Integral a) => [a] -> [a] -> [[a]]
mxs p q = filter (q `isInfixOf`) (all_RTnI p)

-- | Normalize.
nrm :: (Ord a) => [a] -> [a]
nrm = set

-- | Normalize, retain duplicate elements.
nrm_r :: (Ord a) => [a] -> [a]
nrm_r = sort

-- | Pitch-class invariances.
pci :: (Integral a) => [a] -> [a] -> [[a]]
pci p i =
    let f q = set (map (q `genericIndex`) i)
    in filter (\q -> f q == f p) (all_RTnI p)

-- | Relate sets.
rs :: (Integral a) => [a] -> [a] -> [(SRO a, [a])]
rs x y =
    let xs = map (\o -> (o, o `sro` x)) sro_TnMI
        q = set y
    in filter (\(_,p) -> set p == q) xs

-- | Relate segments.
rsg :: (Integral a) => [a] -> [a] -> [(SRO a, [a])]
rsg x y = filter (\(_,x') -> x' == y) (sros x)

-- | Subsets.
sb :: (Integral a) => [[a]] -> [[a]]
sb xs =
    let f p = all id (map (`has_sc` p) xs)
    in filter f scs

-- | Super set-class.
spsc :: (Integral a) => [[a]] -> [String]
spsc xs =
    let f y = all (y `has_sc`) xs
        g = (==) `on` length
    in (map sc_name . head . groupBy g . filter f) scs