module JohnsonTrotter where

import Midi ;
import Pitch ;
import List (inits, tails) ;
import ListLive ;
{-
import List ;
import Function ;
import Prelude ( Integer, (*), (+), mod ) ;
-}


main :: [ Event (Channel Message) ] ;
main :: [Event (Channel Message)]
main =
   Integer -> [Event Message] -> [Event (Channel Message)]
forall a. Integer -> [Event a] -> [Event (Channel a)]
channel Integer
0 ([Event Message] -> [Event (Channel Message)])
-> [Event Message] -> [Event (Channel Message)]
forall a b. (a -> b) -> a -> b
$ Integer -> [Event Message] -> [Event Message]
forall a. Integer -> [Event a] -> [Event a]
changeTempo Integer
timeUnit ([Event Message] -> [Event Message])
-> [Event Message] -> [Event Message]
forall a b. (a -> b) -> a -> b
$ [Event Message] -> [Event Message]
forall a. HasCallStack => [a] -> [a]
cycle ([Event Message] -> [Event Message])
-> [Event Message] -> [Event Message]
forall a b. (a -> b) -> a -> b
$
   ([Integer] -> [Event Message]) -> [[Integer]] -> [Event Message]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Event Message] -> [Event Message]
addBass ([Event Message] -> [Event Message])
-> ([Integer] -> [Event Message]) -> [Integer] -> [Event Message]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> [Event Message]) -> [Integer] -> [Event Message]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Integer -> Integer -> [Event Message]
note Integer
qn (Integer -> [Event Message])
-> (Integer -> Integer) -> Integer -> [Event Message]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Integer
makePitch)) ([[Integer]] -> [Event Message]) -> [[Integer]] -> [Event Message]
forall a b. (a -> b) -> a -> b
$
   [Integer] -> [[Integer]]
forall a. [a] -> [[a]]
johnsonTrotter [Integer]
indexes ;

addBass :: [Event Message] -> [Event Message] ;
addBass :: [Event Message] -> [Event Message]
addBass [Event Message]
xs =
   Integer -> Event Message
noteOn (Integer -> Integer
makePitch Integer
0) Event Message -> [Event Message] -> [Event Message]
forall a. a -> [a] -> [a]
:
   [Event Message]
xs [Event Message] -> [Event Message] -> [Event Message]
forall a. [a] -> [a] -> [a]
++
   Integer -> Event Message
noteOff (Integer -> Integer
makePitch Integer
0) Event Message -> [Event Message] -> [Event Message]
forall a. a -> [a] -> [a]
:
   [] ;

indexes :: [Integer] ;
indexes :: [Integer]
indexes = [Integer
1,Integer
2,Integer
3,Integer
4] ;

makePitch :: Integer -> Pitch ;
makePitch :: Integer -> Integer
makePitch Integer
0 = Integer -> Integer
c Integer
2 ;
makePitch Integer
1 = Integer -> Integer
c Integer
4 ;
makePitch Integer
2 = Integer -> Integer
e Integer
4 ;
makePitch Integer
3 = Integer -> Integer
g Integer
4 ;
makePitch Integer
_ = Integer -> Integer
c Integer
5 ;


-- * Enumerate permutations

{- |
Enumerate permutations with only one swap of adjacent elements
between two successuve permutations.
-}
johnsonTrotter :: [a] -> [[a]] ;
johnsonTrotter :: forall a. [a] -> [[a]]
johnsonTrotter [] = [[]] ;
johnsonTrotter (a
x:[a]
xs) =
   [[[a]]] -> [[a]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[[a]]] -> [[a]]) -> [[[a]]] -> [[a]]
forall a b. (a -> b) -> a -> b
$
   (([a] -> [[a]]) -> [a] -> [[a]])
-> [[a] -> [[a]]] -> [[a]] -> [[[a]]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ([a] -> [[a]]) -> [a] -> [[a]]
forall a. a -> a
id
      ([[a] -> [[a]]] -> [[a] -> [[a]]]
forall a. HasCallStack => [a] -> [a]
cycle [a -> [a] -> [[a]]
forall a. a -> [a] -> [[a]]
walkRight a
x, a -> [a] -> [[a]]
forall a. a -> [a] -> [[a]]
walkLeft a
x])
      ([a] -> [[a]]
forall a. [a] -> [[a]]
johnsonTrotter [a]
xs) ;

{- does not reduce term size
johnsonTrotterInt :: [Integer] -> [[Integer]] ;
johnsonTrotterInt [] = [[]] ;
johnsonTrotterInt (x:xs) =
   concat $
   zipWith applyStrictList
      (cycle [walkRight x, walkLeft x])
      (johnsonTrotterInt xs) ;
-}

{-
reduces term size,
but easily exceeds number of allowed reductions
-}
johnsonTrotterInt :: [Integer] -> [[Integer]] ;
johnsonTrotterInt :: [Integer] -> [[Integer]]
johnsonTrotterInt [] = [[]] ;
johnsonTrotterInt (Integer
x:[Integer]
xs) =
   [[[Integer]]] -> [[Integer]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[[Integer]]] -> [[Integer]]) -> [[[Integer]]] -> [[Integer]]
forall a b. (a -> b) -> a -> b
$
   ([[Integer]] -> [[[Integer]]]) -> [[Integer]] -> [[[Integer]]]
forall a. ([[Integer]] -> a) -> [[Integer]] -> a
applyStrictListList
      ((([Integer] -> [[Integer]]) -> [Integer] -> [[Integer]])
-> [[Integer] -> [[Integer]]] -> [[Integer]] -> [[[Integer]]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ([Integer] -> [[Integer]]) -> [Integer] -> [[Integer]]
forall a. a -> a
id
         ([[Integer] -> [[Integer]]] -> [[Integer] -> [[Integer]]]
forall a. HasCallStack => [a] -> [a]
cycle [Integer -> [Integer] -> [[Integer]]
forall a. a -> [a] -> [[a]]
walkRight Integer
x, Integer -> [Integer] -> [[Integer]]
forall a. a -> [a] -> [[a]]
walkLeft Integer
x]))
      ([Integer] -> [[Integer]]
johnsonTrotterInt [Integer]
xs) ;

walkLeft :: a -> [a] -> [[a]] ;
walkLeft :: forall a. a -> [a] -> [[a]]
walkLeft a
x [a]
xs = [[a]] -> [[a]]
forall a. [a] -> [a]
reverse (a -> [a] -> [[a]]
forall a. a -> [a] -> [[a]]
walkRight a
x [a]
xs) ;

walkRight :: a -> [a] -> [[a]] ;
walkRight :: forall a. a -> [a] -> [[a]]
walkRight a
x [a]
xs =
  ([a] -> [a] -> [a]) -> [[a]] -> [[a]] -> [[a]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (a -> [a] -> [a] -> [a]
forall a. a -> [a] -> [a] -> [a]
insert a
x) ([a] -> [[a]]
forall a. [a] -> [[a]]
inits [a]
xs) ([a] -> [[a]]
forall a. [a] -> [[a]]
tails [a]
xs) ;

insert :: a -> [a] -> [a] -> [a] ;
insert :: forall a. a -> [a] -> [a] -> [a]
insert a
x [a]
prefix [a]
suffix = [a]
prefix [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
suffix ;

-- * auxiliary

timeUnit :: Time ;
timeUnit :: Integer
timeUnit = Integer
150 ;

qn :: Integer ;
qn :: Integer
qn = Integer
1 ;