module Music.Theory.Tiling.Canon where

import Control.Monad {- base -}
import Data.List {- base -}
import Data.List.Split {- split -}
import Text.Printf {- base -}

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

import qualified Music.Theory.List as T {- hmt -}

-- | Sequence.
type S = [Int]

-- | Canon of /(period,sequence,multipliers,displacements)/.
type R = (Int,S,[Int],[Int])

-- | Voice.
type V = [Int]

-- | Tiling (sequence)
type T = [[Int]]

-- | Cycle at /period/.
--
-- > take 9 (p_cycle 18 [0,2,5]) == [0,2,5,18,20,23,36,38,41]
p_cycle :: Int -> [Int] -> [Int]
p_cycle :: Int -> [Int] -> [Int]
p_cycle Int
n [Int]
s = [Int]
s forall a. [a] -> [a] -> [a]
++ Int -> [Int] -> [Int]
p_cycle Int
n (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Num a => a -> a -> a
+ Int
n) [Int]
s)

-- | Element of /(sequence,multiplier,displacement)/.
type E = (S,Int,Int)

-- | Resolve sequence from 'E'.
--
-- > e_to_seq ([0,2,5],2,1) == [1,5,11]
-- > e_to_seq ([0,1],3,4) == [4,7]
-- > e_to_seq ([0],1,2) == [2]
e_to_seq :: E -> [Int]
e_to_seq :: E -> [Int]
e_to_seq ([Int]
s,Int
m,Int
o) = forall a b. (a -> b) -> [a] -> [b]
map ((forall a. Num a => a -> a -> a
+ Int
o) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
* Int
m)) [Int]
s

{- | Infer 'E' from sequence.

> e_from_seq [1,5,11] == ([0,2,5],2,1)
> e_from_seq [4,7] == ([0,1],3,4)
> e_from_seq [2] == ([0],1,2)
-}
e_from_seq :: [Int] -> E
e_from_seq :: [Int] -> E
e_from_seq [Int]
p =
    let i :: Int
i = forall a. [a] -> a
head [Int]
p
        q :: [Int]
q = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Num a => a -> a -> a
+ forall a. Num a => a -> a
negate Int
i) [Int]
p
        r :: [Int]
r = forall a. [a] -> [a]
tail [Int]
q
        n :: Int
n = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
r then Int
1 else forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 forall a. Integral a => a -> a -> a
gcd [Int]
r
    in (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Integral a => a -> a -> a
`div` Int
n) [Int]
q,Int
n,Int
i)

-- | Set of 'V' from 'R'.
r_voices :: R -> [V]
r_voices :: R -> T
r_voices (Int
p,[Int]
s,[Int]
m,[Int]
o) =
    let f :: Int -> Int -> [Int]
f Int
i Int
j = Int -> [Int] -> [Int]
p_cycle Int
p (E -> [Int]
e_to_seq ([Int]
s,Int
i,Int
j))
    in forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Int -> [Int]
f [Int]
m [Int]
o

-- | 'concatMap' of 'r_voices'.
rr_voices :: [R] -> [V]
rr_voices :: [R] -> T
rr_voices = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap R -> T
r_voices

-- | Retrograde of 'T', the result 'T' is sorted.
--
-- > let r = [[0,7,14],[1,5,9],[2,4,6],[3,8,13],[10,11,12]]
-- > t_retrograde [[0,7,14],[1,6,11],[2,3,4],[5,9,13],[8,10,12]] == r
t_retrograde :: T -> T
t_retrograde :: T -> T
t_retrograde T
t =
    let n :: Int
n = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat T
t)
    in forall a. Ord a => [a] -> [a]
sort (forall a b. (a -> b) -> [a] -> [b]
map (forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Int
n forall a. Num a => a -> a -> a
-)) T
t)

-- | The normal form of 'T' is the 'min' of /t/ and it's 't_retrograde'.
--
-- > let r = [[0,7,14],[1,5,9],[2,4,6],[3,8,13],[10,11,12]]
-- > t_normal [[0,7,14],[1,6,11],[2,3,4],[5,9,13],[8,10,12]] == r
t_normal :: T -> T
t_normal :: T -> T
t_normal T
t = forall a. Ord a => a -> a -> a
min T
t (T -> T
t_retrograde T
t)

{- | Derive set of 'R' from 'T'.

> let r = [(21,[0,1,2],[10,8,2,4,7,5,1],[0,1,2,3,5,8,14])]
> let t = [[0,10,20],[1,9,17],[2,4,6],[3,7,11],[5,12,19],[8,13,18],[14,15,16]]
> r_from_t t == r
-}
r_from_t :: T -> [R]
r_from_t :: T -> [R]
r_from_t T
t =
    let e :: [E]
e = forall a b. (a -> b) -> [a] -> [b]
map [Int] -> E
e_from_seq T
t
        n :: Int
n = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat T
t) forall a. Num a => a -> a -> a
+ Int
1
        t3_1 :: (a, b, c) -> a
t3_1 (a
i,b
_,c
_) = a
i
        f :: [(b, b, c)] -> (Int, b, [b], [c])
f [(b, b, c)]
z = let ([b]
s,[b]
m,[c]
o) = forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [(b, b, c)]
z in (Int
n,forall a. [a] -> a
head [b]
s,[b]
m,[c]
o)
    in forall a b. (a -> b) -> [a] -> [b]
map forall {b} {b} {c}. [(b, b, c)] -> (Int, b, [b], [c])
f (forall x a. Eq x => (a -> x) -> [a] -> [[a]]
T.group_on forall {a} {b} {c}. (a, b, c) -> a
t3_1 [E]
e)

-- * Construction

-- | '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

-- | Search for /perfect/ tilings of the sequence 'S' using
-- multipliers from /m/ to degree /n/ with /k/ parts.
perfect_tilings_m :: MonadPlus m => [S] -> [Int] -> Int -> Int -> m T
perfect_tilings_m :: forall (m :: * -> *).
MonadPlus m =>
T -> [Int] -> Int -> Int -> m T
perfect_tilings_m T
s [Int]
m Int
n Int
k =
    let rec :: [Int] -> T -> m T
rec [Int]
p T
q =
            if forall (t :: * -> *) a. Foldable t => t a -> Int
length T
q forall a. Eq a => a -> a -> Bool
== Int
k
            then forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Ord a => [a] -> [a]
sort T
q)
            else do Int
m' <- forall (m :: * -> *) a. MonadPlus m => [a] -> m a
fromList [Int]
m
                    forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
m' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Int]
p)
                    [Int]
s' <- forall (m :: * -> *) a. MonadPlus m => [a] -> m a
fromList T
s
                    let i :: Int
i = Int
n forall a. Num a => a -> a -> a
- (forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
s' forall a. Num a => a -> a -> a
* Int
m') forall a. Num a => a -> a -> a
- Int
1
                    Int
o <- forall (m :: * -> *) a. MonadPlus m => [a] -> m a
fromList [Int
0..Int
i]
                    let s'' :: [Int]
s'' = E -> [Int]
e_to_seq ([Int]
s',Int
m',Int
o)
                        q' :: [Int]
q' = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat T
q
                    forall (f :: * -> *). Alternative f => Bool -> f ()
guard (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Int]
q') [Int]
s'')
                    [Int] -> T -> m T
rec (Int
m'forall a. a -> [a] -> [a]
:[Int]
p) ([Int]
s''forall a. a -> [a] -> [a]
:T
q)
    in forall {m :: * -> *}. MonadPlus m => [Int] -> T -> m T
rec [] []

{- | 't_normal' of 'L.observeAll' of 'perfect_tilings_m'.

> perfect_tilings [[0,1]] [1..3] 6 3 == []

> let r = [[[0,7,14],[1,5,9],[2,4,6],[3,8,13],[10,11,12]]]
> perfect_tilings [[0,1,2]] [1,2,4,5,7] 15 5 == r

> length (perfect_tilings [[0,1,2]] [1..12] 15 5) == 1

> let r = [[[0,1],[2,5],[3,7],[4,6]], [[0,1],[2,6],[3,5],[4,7]] ,[[0,2],[1,4],[3,7],[5,6]]]
> perfect_tilings [[0,1]] [1..4] 8 4 == r

> let r = [[[0,1],[2,5],[3,7],[4,9],[6,8]]
>         ,[[0,1],[2,7],[3,5],[4,8],[6,9]]
>         ,[[0,2],[1,4],[3,8],[5,9],[6,7]]
>         ,[[0,2],[1,5],[3,6],[4,9],[7,8]]
>         ,[[0,3],[1,6],[2,4],[5,9],[7,8]]]
> in perfect_tilings [[0,1]] [1..5] 10 5 == r

Johnson 2004, p.2

> let r = [[0,6,12],[1,8,15],[2,11,20],[3,5,7],[4,9,14],[10,13,16],[17,18,19]]
> perfect_tilings [[0,1,2]] [1,2,3,5,6,7,9] 21 7 == [r]

> let r = [[0,10,20],[1,9,17],[2,4,6],[3,7,11],[5,12,19],[8,13,18],[14,15,16]]
> perfect_tilings [[0,1,2]] [1,2,4,5,7,8,10] 21 7 == [t_retrograde r]

-}
perfect_tilings :: [S] -> [Int] -> Int -> Int -> [T]
perfect_tilings :: T -> [Int] -> Int -> Int -> [T]
perfect_tilings T
s [Int]
m Int
n =
    forall a. Eq a => [a] -> [a]
nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map T -> T
t_normal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Logic a -> [a]
L.observeAll forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
MonadPlus m =>
T -> [Int] -> Int -> Int -> m T
perfect_tilings_m T
s [Int]
m Int
n

-- * Display

-- | Variant of 'elem' for ordered sequences, which can therefore
-- return 'False' when searching infinite sequences.
--
-- > 5 `elemOrd` [0,2..] == False && 10 `elemOrd` [0,2..] == True
elemOrd :: Ord a => a -> [a] -> Bool
elemOrd :: forall a. Ord a => a -> [a] -> Bool
elemOrd a
i [a]
p =
    case [a]
p of
      [] -> Bool
False
      a
j:[a]
p' -> case forall a. Ord a => a -> a -> Ordering
compare a
j a
i of
                Ordering
LT -> forall a. Ord a => a -> [a] -> Bool
elemOrd a
i [a]
p'
                Ordering
EQ -> Bool
True
                Ordering
GT -> Bool
False

-- | A @.*@ diagram of /n/ places of 'V'.
--
-- > v_dot_star 18 [0,2..] == "*.*.*.*.*.*.*.*.*."
v_dot_star :: Int -> V -> String
v_dot_star :: Int -> [Int] -> String
v_dot_star Int
n [Int]
v =
    let f :: [a] -> a -> Char
f [a]
p a
i = if a
i forall a. Ord a => a -> [a] -> Bool
`elemOrd` [a]
p then Char
'*' else Char
'.'
    in forall a b. (a -> b) -> [a] -> [b]
map (forall {a}. Ord a => [a] -> a -> Char
f [Int]
v) [Int
0..Int
nforall a. Num a => a -> a -> a
-Int
1]

-- | A white space and index diagram of /n/ places of 'V'.
--
-- >>> mapM_ (putStrLn . v_space_ix 9) [[0,2..],[1,3..]]
-- >
-- >  0   2   4   6   8
-- >    1   3   5   7
v_space_ix :: Int -> V -> String
v_space_ix :: Int -> [Int] -> String
v_space_ix Int
n [Int]
v =
    let w :: Int
w = forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a. Show a => a -> String
show Int
n)
        nil :: String
nil = forall a. Int -> a -> [a]
replicate Int
w Char
' '
        f :: [t] -> t -> String
f [t]
p t
i = if t
i forall a. Ord a => a -> [a] -> Bool
`elemOrd` [t]
p then forall r. PrintfType r => String -> r
printf String
"%*d" Int
w t
i else String
nil
    in [String] -> String
unwords (forall a b. (a -> b) -> [a] -> [b]
map (forall {t}. (Ord t, PrintfArg t) => [t] -> t -> String
f [Int]
v) [Int
0..Int
nforall a. Num a => a -> a -> a
-Int
1])

-- | Insert @|@ every /n/ places.
--
-- > with_bars 6 (v_dot_star 18 [0,2..]) == "*.*.*.|*.*.*.|*.*.*."
with_bars :: Int -> String -> String
with_bars :: Int -> String -> String
with_bars Int
m = forall a. [a] -> [[a]] -> [a]
intercalate String
"|" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Int -> [e] -> [[e]]
chunksOf Int
m

-- | Variant with measure length /m/ and number of measures /n/.
--
-- > v_dot_star_m 6 3 [0,2..] == "*.*.*.|*.*.*.|*.*.*."
v_dot_star_m :: Int -> Int -> V -> String
v_dot_star_m :: Int -> Int -> [Int] -> String
v_dot_star_m Int
m Int
n = Int -> String -> String
with_bars Int
m forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Int] -> String
v_dot_star (Int
n forall a. Num a => a -> a -> a
* Int
m)

-- | Print @.*@ diagram.
v_print :: Int -> [V] -> IO ()
v_print :: Int -> T -> IO ()
v_print Int
n = String -> IO ()
putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"" forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Int -> [Int] -> String
v_dot_star Int
n)

-- | Variant to print @|@ at measures.
v_print_m :: Int -> Int -> [V] -> IO ()
v_print_m :: Int -> Int -> T -> IO ()
v_print_m Int
m Int
n = String -> IO ()
putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"" forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> [Int] -> String
v_dot_star_m Int
m Int
n)

-- | Variant that discards first /k/ measures.
v_print_m_from :: Int -> Int -> Int -> [V] -> IO ()
v_print_m_from :: Int -> Int -> Int -> T -> IO ()
v_print_m_from Int
k Int
m Int
n =
    let k' :: Int
k' = Int
k forall a. Num a => a -> a -> a
* Int
m
        f :: [Int] -> String
f = Int -> String -> String
with_bars Int
m forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
k' forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Int] -> String
v_dot_star (Int
n forall a. Num a => a -> a -> a
* Int
m forall a. Num a => a -> a -> a
+ Int
k')
    in String -> IO ()
putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"" forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map [Int] -> String
f