-- | Robert Morris and D. Starr. \"The Structure of All-Interval Series\".
-- /Journal of Music Theory/, 18:364-389, 1974.
module Music.Theory.Z.Morris_1974 where

import Control.Monad {- base -}

import qualified Control.Monad.Logic as L {- logict -}

-- | 'msum' '.' 'map' 'return'.
--
-- > L.observeAll (fromList [1..7]) == [1..7]
fromList :: MonadPlus m => [a] -> m a
fromList :: forall (m :: * -> *) a. MonadPlus m => [a] -> m a
fromList = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *) a. Monad m => a -> m a
return

-- | Interval from /i/ to /j/ in modulo-/n/.
--
-- > let f = int_n 12 in (f 0 11,f 11 0) == (11,1)
int_n :: Integral a => a -> a -> a -> a
int_n :: forall a. Integral a => a -> a -> a -> a
int_n a
n a
i a
j = forall a. Num a => a -> a
abs ((a
j forall a. Num a => a -> a -> a
- a
i) forall a. Integral a => a -> a -> a
`mod` a
n)

-- | 'L.MonadLogic' all-interval series.
--
-- > map (length . L.observeAll . all_interval_m) [4,6,8,10] == [2,4,24,288]
-- > [0,1,3,2,9,5,10,4,7,11,8,6] `elem` L.observeAll (all_interval_m 12)
-- > length (L.observeAll (all_interval_m 12)) == 3856
all_interval_m :: (MonadPlus m, L.MonadLogic m) => Int -> m [Int]
all_interval_m :: forall (m :: * -> *). (MonadPlus m, MonadLogic m) => Int -> m [Int]
all_interval_m Int
n =
    let recur :: Int -> [Int] -> [Int] -> m [Int]
recur Int
k [Int]
p [Int]
q = -- k = length p, p = pitch-class sequence, q = interval set
            if Int
k forall a. Eq a => a -> a -> Bool
== Int
n
            then forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> [a]
reverse [Int]
p)
            else do Int
i <- forall (m :: * -> *) a. MonadPlus m => [a] -> m a
fromList [Int
1 .. Int
n forall a. Num a => a -> a -> a
- Int
1]
                    forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
i forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Int]
p)
                    let j :: Int
j = forall a. [a] -> a
head [Int]
p
                        m :: Int
m = forall a. Integral a => a -> a -> a -> a
int_n Int
n Int
i Int
j
                    forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
m forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Int]
q)
                    Int -> [Int] -> [Int] -> m [Int]
recur (Int
k forall a. Num a => a -> a -> a
+ Int
1) (Int
i forall a. a -> [a] -> [a]
: [Int]
p) (Int
m forall a. a -> [a] -> [a]
: [Int]
q)
    in forall {m :: * -> *}.
MonadPlus m =>
Int -> [Int] -> [Int] -> m [Int]
recur Int
1 [Int
0] []

{- | 'L.observeAll' of 'all_interval_m'.

> let r = [[0,1,5,2,4,3],[0,2,1,4,5,3],[0,4,5,2,1,3],[0,5,1,4,2,3]]
> all_interval 6 == r

> d_dx_n n l = zipWith (int_n n) l (tail l)
> map (d_dx_n 6) r == [[1,4,3,2,5],[2,5,3,1,4],[4,1,3,5,2],[5,2,3,4,1]]

-}
all_interval :: Int -> [[Int]]
all_interval :: Int -> [[Int]]
all_interval = forall a. Logic a -> [a]
L.observeAll forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). (MonadPlus m, MonadLogic m) => Int -> m [Int]
all_interval_m