-- | Godfried T. Toussaint et. al.
-- \"The distance geometry of music\"
-- /Journal of Computational Geometry: Theory and Applications/
-- Volume 42, Issue 5, July, 2009
-- (<http://dx.doi.org/10.1016/j.comgeo.2008.04.005>)
module Music.Theory.Bjorklund where

import Data.List.Split {- split -}

import qualified Music.Theory.List as T

-- | Bjorklund state
type BJORKLUND_ST a = ((Int,Int),([[a]],[[a]]))

-- | Bjorklund left process
bjorklund_left_f :: BJORKLUND_ST a -> BJORKLUND_ST a
bjorklund_left_f :: forall a. BJORKLUND_ST a -> BJORKLUND_ST a
bjorklund_left_f ((Int
i,Int
j),([[a]]
xs,[[a]]
ys)) =
    let ([[a]]
xs',[[a]]
xs'') = forall a. Int -> [a] -> ([a], [a])
splitAt Int
j [[a]]
xs
    in ((Int
j,Int
iforall a. Num a => a -> a -> a
-Int
j),(forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. [a] -> [a] -> [a]
(++) [[a]]
xs' [[a]]
ys,[[a]]
xs''))

-- | Bjorklund right process
bjorklund_right_f :: BJORKLUND_ST a -> BJORKLUND_ST a
bjorklund_right_f :: forall a. BJORKLUND_ST a -> BJORKLUND_ST a
bjorklund_right_f ((Int
i,Int
j),([[a]]
xs,[[a]]
ys)) =
    let ([[a]]
ys',[[a]]
ys'') = forall a. Int -> [a] -> ([a], [a])
splitAt Int
i [[a]]
ys
    in ((Int
i,Int
jforall a. Num a => a -> a -> a
-Int
i),(forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. [a] -> [a] -> [a]
(++) [[a]]
xs [[a]]
ys',[[a]]
ys''))

-- | Bjorklund process, left & recur or right & recur or halt.
bjorklund_f :: BJORKLUND_ST a -> BJORKLUND_ST a
bjorklund_f :: forall a. BJORKLUND_ST a -> BJORKLUND_ST a
bjorklund_f ((Int, Int)
n,([[a]], [[a]])
x) =
    let (Int
i,Int
j) = (Int, Int)
n
    in if forall a. Ord a => a -> a -> a
min Int
i Int
j forall a. Ord a => a -> a -> Bool
<= Int
1
       then ((Int, Int)
n,([[a]], [[a]])
x)
       else forall a. BJORKLUND_ST a -> BJORKLUND_ST a
bjorklund_f (if Int
i forall a. Ord a => a -> a -> Bool
> Int
j then forall a. BJORKLUND_ST a -> BJORKLUND_ST a
bjorklund_left_f ((Int, Int)
n,([[a]], [[a]])
x) else forall a. BJORKLUND_ST a -> BJORKLUND_ST a
bjorklund_right_f ((Int, Int)
n,([[a]], [[a]])
x))

{- | Bjorklund's algorithm to construct a binary sequence of /n/ bits
with /k/ ones such that the /k/ ones are distributed as evenly as
possible among the (/n/ - /k/) zeroes.

> bjorklund (5,9) == [True,False,True,False,True,False,True,False,True]
> map xdot_ascii (bjorklund (5,9)) == "x.x.x.x.x"

> let es = [(2,[3,5]),(3,[4,5,8]),(4,[7,9,12,15]),(5,[6,7,8,9,11,12,13,16]),(6,[7,13]),(7,[8,9,10,12,15,16,17,18]),(8,[17,19]),(9,[14,16,22,23]),(11,[12,24]),(13,[24]),(15,[34])]
> let es' = concatMap (\(i,j) -> map ((,) i) j) es
> mapM_ (putStrLn . euler_pp_unicode) es'

> > E(2,3) [××·] (12)
> > E(2,5) [×·×··] (23)
> > E(3,4) [×××·] (112)
> > E(3,5) [×·×·×] (221)
> > E(3,8) [×··×··×·] (332)
> > E(4,7) [×·×·×·×] (2221)
> > E(4,9) [×·×·×·×··] (2223)
> > E(4,12) [×··×··×··×··] (3333)
> > E(4,15) [×···×···×···×··] (4443)
> > E(5,6) [×××××·] (11112)
> > E(5,7) [×·××·××] (21211)
> > E(5,8) [×·××·××·] (21212)
> > E(5,9) [×·×·×·×·×] (22221)
> > E(5,11) [×·×·×·×·×··] (22223)
> > E(5,12) [×··×·×··×·×·] (32322)
> > E(5,13) [×··×·×··×·×··] (32323)
> > E(5,16) [×··×··×··×··×···] (33334)
> > E(6,7) [××××××·] (111112)
> > E(6,13) [×·×·×·×·×·×··] (222223)
> > E(7,8) [×××××××·] (1111112)
> > E(7,9) [×·×××·×××] (2112111)
> > E(7,10) [×·××·××·××] (2121211)
> > E(7,12) [×·××·×·××·×·] (2122122)
> > E(7,15) [×·×·×·×·×·×·×··] (2222223)
> > E(7,16) [×··×·×·×··×·×·×·] (3223222)
> > E(7,17) [×··×·×··×·×··×·×·] (3232322)
> > E(7,18) [×··×·×··×·×··×·×··] (3232323)
> > E(8,17) [×·×·×·×·×·×·×·×··] (22222223)
> > E(8,19) [×··×·×·×··×·×·×··×·] (32232232)
> > E(9,14) [×·××·××·××·××·] (212121212)
> > E(9,16) [×·××·×·×·××·×·×·] (212221222)
> > E(9,22) [×··×·×··×·×··×·×··×·×·] (323232322)
> > E(9,23) [×··×·×··×·×··×·×··×·×··] (323232323)
> > E(11,12) [×××××××××××·] (11111111112)
> > E(11,24) [×··×·×·×·×·×··×·×·×·×·×·] (32222322222)
> > E(13,24) [×·××·×·×·×·×·××·×·×·×·×·] (2122222122222)
> > E(15,34) [×··×·×·×·×··×·×·×·×··×·×·×·×··×·×·] (322232223222322)

-}
bjorklund :: (Int,Int) -> [Bool]
bjorklund :: (Int, Int) -> [Bool]
bjorklund (Int
i,Int
j') =
    let j :: Int
j = Int
j' forall a. Num a => a -> a -> a
- Int
i
        x :: [[Bool]]
x = forall a. Int -> a -> [a]
replicate Int
i [Bool
True]
        y :: [[Bool]]
y = forall a. Int -> a -> [a]
replicate Int
j [Bool
False]
        ((Int, Int)
_,([[Bool]]
x',[[Bool]]
y')) = forall a. BJORKLUND_ST a -> BJORKLUND_ST a
bjorklund_f ((Int
i,Int
j),([[Bool]]
x,[[Bool]]
y))
    in forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Bool]]
x' forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Bool]]
y'

-- | 'T.rotate_right' of 'bjorklund'.
--
-- > map xdot_unicode (bjorklund_r 2 (5,16)) == "··×··×··×··×··×·"
bjorklund_r :: Int -> (Int, Int) -> [Bool]
bjorklund_r :: Int -> (Int, Int) -> [Bool]
bjorklund_r Int
n = forall a. Int -> [a] -> [a]
T.rotate_right Int
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> [Bool]
bjorklund

-- | Pretty printer, generalise.
euler_pp_f :: (Bool -> Char) -> (Int,Int) -> String
euler_pp_f :: (Bool -> Char) -> (Int, Int) -> String
euler_pp_f Bool -> Char
f (Int, Int)
e =
    let r :: [Bool]
r = (Int, Int) -> [Bool]
bjorklund (Int, Int)
e
    in forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"E",forall a. Show a => a -> String
show (Int, Int)
e,String
" [",forall a b. (a -> b) -> [a] -> [b]
map Bool -> Char
f [Bool]
r,String
"] ",[Bool] -> String
iseq_str [Bool]
r]

-- | Unicode form, ie. @×·@.
--
-- > euler_pp_unicode (7,12) == "E(7,12) [×·××·×·××·×·] (2122122)"
euler_pp_unicode :: (Int, Int) -> String
euler_pp_unicode :: (Int, Int) -> String
euler_pp_unicode = (Bool -> Char) -> (Int, Int) -> String
euler_pp_f Bool -> Char
xdot_unicode

-- | ASCII form, ie. @x.@.
--
-- > euler_pp_ascii (7,12) == "E(7,12) [x.xx.x.xx.x.] (2122122)"
euler_pp_ascii :: (Int, Int) -> String
euler_pp_ascii :: (Int, Int) -> String
euler_pp_ascii = (Bool -> Char) -> (Int, Int) -> String
euler_pp_f Bool -> Char
xdot_ascii

-- | /xdot/ notation for pattern.
--
-- > map xdot_ascii (bjorklund (5,9)) == "x.x.x.x.x"
xdot_ascii :: Bool -> Char
xdot_ascii :: Bool -> Char
xdot_ascii Bool
x = if Bool
x then Char
'x' else Char
'.'

-- | Unicode variant.
--
-- > map xdot_unicode (bjorklund (5,12)) == "×··×·×··×·×·"
-- > map xdot_unicode (bjorklund (5,16)) == "×··×··×··×··×···"
xdot_unicode :: Bool -> Char
xdot_unicode :: Bool -> Char
xdot_unicode Bool
x = if Bool
x then Char
'×' else Char
'·'

-- | The 'iseq' of a pattern is the distance between 'True' values.
--
-- > iseq (bjorklund (5,9)) == [2,2,2,2,1]
iseq :: [Bool] -> [Int]
iseq :: [Bool] -> [Int]
iseq = let f :: (a -> Bool) -> [a] -> [[a]]
f = forall a. Splitter a -> [a] -> [[a]]
split forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Splitter a -> Splitter a
keepDelimsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> Splitter a
whenElt in forall a. [a] -> [a]
tail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. (a -> Bool) -> [a] -> [[a]]
f (forall a. Eq a => a -> a -> Bool
== Bool
True)

-- | 'iseq' of pattern as compact string.
--
-- > iseq_str (bjorklund (5,9)) == "(22221)"
iseq_str :: [Bool] -> String
iseq_str :: [Bool] -> String
iseq_str = let f :: t a -> String
f t a
xs = String
"(" forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. Show a => a -> String
show t a
xs forall a. [a] -> [a] -> [a]
++ String
")" in forall {t :: * -> *} {a}. (Foldable t, Show a) => t a -> String
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Bool] -> [Int]
iseq